Giúp Code lập bảng tổng hợp diện tích theo Mã loại đất

[hemhjhjchocchoc99]

Em có một bài toán muốn nhờ AC viết hộ Code như sau:
Em có bảng liệt kê diện tích các khoanh đất với mã loại đất theo hiện trạng. Em muốn viết code tìm đến dòng cuối cùng trong bảng, tìm các mã loại đất giống nhau cộng dồn diện tích lại với nhau và cuối cùng ra được diện tích tổng của mã loại đất đó!
Với các mã loại đất không giống nhau thì vẫn giữ nguyên diện tích! EM muốn khi tổng hợp xong diện tích mã loại đất sẽ được chạy tự động sang sheet mới ạ!
Diện tích ở cột B và Mã loại đất theo hiện trạng ở cột C ạ. Em cảm ơn các Anh, Chị!

 

[snow25]

Em có một bài toán muốn nhờ AC viết hộ Code như sau:
Em có bảng liệt kê diện tích các khoanh đất với mã loại đất theo hiện trạng. Em muốn viết code tìm đến dòng cuối cùng trong bảng, tìm các mã loại đất giống nhau cộng dồn diện tích lại với nhau và cuối cùng ra được diện tích tổng của mã loại đất đó!
Với các mã loại đất không giống nhau thì vẫn giữ nguyên diện tích! EM muốn khi tổng hợp xong diện tích mã loại đất sẽ được chạy tự động sang sheet mới ạ!
Diện tích ở cột B và Mã loại đất theo hiện trạng ở cột C ạ. Em cảm ơn các Anh, Chị!

Bạn thử code này.

Sub aa()
    Dim dic As Object, i As Long, lr As Long, arr, arr1, a As Long, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("PL03")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("b8:C" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 3)
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             If Not dic.exists(dk) Then
                a = a + 1
                arr1(a, 1) = a
                arr1(a, 2) = arr(i, 1)
                arr1(a, 3) = arr(i, 2)
                dic.Add dk, a
             Else
                b = dic.Item(dk)
                arr1(b, 2) = arr1(b, 2) + arr(i, 1)
             End If
        Next i
     End With
     With Sheets("kq")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 7 Then .Range("a8:C" & lr).ClearContents
         If a Then .Range("A8:C8").Resize(a).Value = arr1
     End With
End Sub

 

[be_09]

Em có một bài toán muốn nhờ AC viết hộ Code như sau:
Em có bảng liệt kê diện tích các khoanh đất với mã loại đất theo hiện trạng. Em muốn viết code tìm đến dòng cuối cùng trong bảng, tìm các mã loại đất giống nhau cộng dồn diện tích lại với nhau và cuối cùng ra được diện tích tổng của mã loại đất đó!
Với các mã loại đất không giống nhau thì vẫn giữ nguyên diện tích! EM muốn khi tổng hợp xong diện tích mã loại đất sẽ được chạy tự động sang sheet mới ạ!
Diện tích ở cột B và Mã loại đất theo hiện trạng ở cột C ạ. Em cảm ơn các Anh, Chị!

Xem cách sử dụng PivotTable ở sheet1.

 

[hemhjhjchocchoc99]

Bạn thử code này.

Sub aa()
    Dim dic As Object, i As Long, lr As Long, arr, arr1, a As Long, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("PL03")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("b8:C" & lr).Value
         ReDim arr1(1 To UBound(arr, 1), 1 To 3)
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             If Not dic.exists(dk) Then
                a = a + 1
                arr1(a, 1) = a
                arr1(a, 2) = arr(i, 1)
                arr1(a, 3) = arr(i, 2)
                dic.Add dk, a
             Else
                b = dic.Item(dk)
                arr1(b, 2) = arr1(b, 2) + arr(i, 1)
             End If
        Next i
     End With
     With Sheets("kq")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 7 Then .Range("a8:C" & lr).ClearContents
         If a Then .Range("A8:C8").Resize(a).Value = arr1
     End With
End Sub

Wow, em cảm ơn ạ!