Nhờ giúp code VBA gom các lô hàng trùng nhau?

[hitlecp]

Chào anh, chị
Em có file excel dữ liệu kết xuất về cả ngàn dòng, nhờ anh chị giúp em code VBA (không dùng Pivot Table) gom tổng số lượng các số lô hàng trùng nhau lại. Em có đính kèm file. Nhờ anh, chị giúp em với ạ.
Em cảm ơn.

 

[Phuocam]

Bạn tìm hiểu thêm về Scripting.Dictionary. Đây là bài mẫu:

Tổng quan về Scripting.Dictionary

Với những ai yêu thích Excel nói chung và yêu thích VBA nói riêng thì chắc hẳn cũng đã biết qua các khái niệm về mảng, về công thức điều kiện, vòng lặp,..., những thứ rất quen thuộc mà gần như là sử dụng thường xuyên trong từng bài toán lập trình. Tuy nhiên, có lẽ sẽ rất ít người biết về...

www.giaiphapexcel.com

 

[leonguyenz]

Chào anh, chị
Em có file excel dữ liệu kết xuất về cả ngàn dòng, nhờ anh chị giúp em code VBA (không dùng Pivot Table) gom tổng số lượng các số lô hàng trùng nhau lại. Em có đính kèm file. Nhờ anh, chị giúp em với ạ.
Em cảm ơn.

Sửa code một chút từ link bài #2

Sub TongHop()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheet1
    .Range("H4:I" & .Range("I65535").End(xlUp).Row).ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = .Range("A4:B" & .Range("A65535").End(xlUp).Row).Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 2)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not Dic1.exists(TmpArr(iRow, 1)) Then
            i = i + 1
            Dic1.Add TmpArr(iRow, 1), i
            Arr(i, 1) = TmpArr(iRow, 1)
            Arr(i, 2) = TmpArr(iRow, 2)
        Else
            Arr(Dic1.Item(TmpArr(iRow, 1)), 2) = _
            Arr(Dic1.Item(TmpArr(iRow, 1)), 2) + TmpArr(iRow, 2)
        End If
    Next iRow
    .Range("H4").Resize(i, 2).Value = Arr
    Set Dic1 = Nothing
End With
End Sub

 

[hitlecp]

Sửa code một chút từ link bài #2

Sub TongHop()
Dim Dic1 As Object, iRow As Long, i As Long
Dim Arr() As Variant, TmpArr As Variant
With Sheet1
    .Range("H4:I" & .Range("I65535").End(xlUp).Row).ClearContents
  Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = .Range("A4:B" & .Range("A65535").End(xlUp).Row).Value
    ReDim Arr(1 To UBound(TmpArr, 1), 1 To 2)
    For iRow = 1 To UBound(TmpArr, 1)
        If Not Dic1.exists(TmpArr(iRow, 1)) Then
            i = i + 1
            Dic1.Add TmpArr(iRow, 1), i
            Arr(i, 1) = TmpArr(iRow, 1)
            Arr(i, 2) = TmpArr(iRow, 2)
        Else
            Arr(Dic1.Item(TmpArr(iRow, 1)), 2) = _
            Arr(Dic1.Item(TmpArr(iRow, 1)), 2) + TmpArr(iRow, 2)
        End If
    Next iRow
    .Range("H4").Resize(i, 2).Value = Arr
    Set Dic1 = Nothing
End With
End Sub

Em cảm ơn nhiều ạ