Hỏi code Dic có chức năng tương tự như hàm Sumif trên excel - Không duy nhất (1 người xem)

[hcm2015]

Chào các bạn!

Các bạn giúp tôi cải tiến Code DIC trong file đính kèm có chức năng tương tự hàm sumif. Tôi có ghi chú trong file.

Ghi chú: Cột I & J là có sẵn. Kết quả ghi vào cột K và L. Cột J không phải là duy nhất
+ Cột K kết quả như vlookup, code trong file đã Ok cột này
+ Cột L là Khối lượng. Yêu cầu là Cộng dồn (hay tổng lại) dữ liệu từ bảng Dữ liệu đầu vào như đã dùng Sumif tại cột M


XIN TRÂN TRỌNG CẢM ƠN CÁC BẠN ĐÃ ĐỌC!

 

[Ba Tê]

Chào các bạn!

Các bạn giúp tôi cải tiến Code DIC trong file đính kèm có chức năng tương tự hàm sumif. Tôi có ghi chú trong file.

Ghi chú: Cột I & J là có sẵn. Kết quả ghi vào cột K và L. Cột J không phải là duy nhất
+ Cột K kết quả như vlookup, code trong file đã Ok cột này
+ Cột L là Khối lượng. Yêu cầu là Cộng dồn (hay tổng lại) dữ liệu từ bảng Dữ liệu đầu vào như đã dùng Sumif tại cột M


XIN TRÂN TRỌNG CẢM ƠN CÁC BẠN ĐÃ ĐỌC!

Chưa hiểu lắm ý của bạn.
Chỉnh lại Sub của bạn, nếu đúng ý thì xài.

Public Sub Test()
Dim Dic As Object, dArr(), sArr(), tArr(), I As Long, K As Long, Rws As Long, Itm As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([C3], [C3].End(xlDown)).Resize(, 3).Value
ReDim tArr(1 To UBound(sArr, 1), 1 To 2)
For I = 1 To UBound(sArr, 1)
    Itm = sArr(I, 1)
    If Not Dic.exists(Itm) Then
        K = K + 1
        Dic.Add Itm, K
        tArr(K, 1) = sArr(I, 2)
        tArr(K, 2) = sArr(I, 3)
    Else
        Rws = Dic.Item(Itm)
        tArr(Rws, 2) = tArr(Rws, 2) + sArr(I, 3)
    End If
Next I
sArr = Range([J3], [J3].End(xlDown)).Value
ReDim dArr(1 To UBound(sArr), 1 To 2)
For I = 1 To UBound(sArr)
    Itm = sArr(I, 1)
    If Dic.exists(Itm) Then
        Rws = Dic.Item(Itm)
        dArr(I, 1) = tArr(Rws, 1)
        dArr(I, 2) = tArr(Rws, 2)
    End If
Next I
[K3:L65000].ClearContents
[K3].Resize(I - 1, 2) = dArr
Set Dic = Nothing
End Sub

 

[hcm2015]

Chưa hiểu lắm ý của bạn.
Chỉnh lại Sub của bạn, nếu đúng ý thì xài.

Public Sub Test()
Dim Dic As Object, dArr(), sArr(), tArr(), I As Long, K As Long, Rws As Long, Itm As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([C3], [C3].End(xlDown)).Resize(, 3).Value
ReDim tArr(1 To UBound(sArr, 1), 1 To 2)
For I = 1 To UBound(sArr, 1)
    Itm = sArr(I, 1)
    If Not Dic.exists(Itm) Then
        K = K + 1
        Dic.Add Itm, K
        tArr(K, 1) = sArr(I, 2)
        tArr(K, 2) = sArr(I, 3)
    Else
        Rws = Dic.Item(Itm)
        tArr(Rws, 2) = tArr(Rws, 2) + sArr(I, 3)
    End If
Next I
sArr = Range([J3], [J3].End(xlDown)).Value
ReDim dArr(1 To UBound(sArr), 1 To 2)
For I = 1 To UBound(sArr)
    Itm = sArr(I, 1)
    If Dic.exists(Itm) Then
        Rws = Dic.Item(Itm)
        dArr(I, 1) = tArr(Rws, 1)
        dArr(I, 2) = tArr(Rws, 2)
    End If
Next I
[K3:L65000].ClearContents
[K3].Resize(I - 1, 2) = dArr
Set Dic = Nothing
End Sub

Quá tuyệt. Code đúng ý mình rồi. Trân trọng cảm ơn BaTê
(Chìa khóa ở đây là tạo thêm một mảng Ảo tArr như code anh vừa làm, rất là hay ạ!)

 

[Trần Văn Bình]

Quan điểm của mình kết quả không đúng vì Tại cột J3 đến J14 các dữ liệu bị trùng do vật kết quản sumif() sẽ là 02 lần

 

[hcm2015]

Quan điểm của mình kết quả không đúng vì Tại cột J3 đến J14 các dữ liệu bị trùng do vật kết quản sumif() sẽ là 02 lần

Như tiêu đề topic là chủ ý của mình đó bạn ạ! Chứ nếu mà không trùng thì mình đã biết xử lý rồi... Mình muốn học thêm trường hợp với dữ liệu Kiểu trời ơi "Bị trùng lắp" như ví dụ mình đưa ra để tham khảo code tương tự như cách mà hàm Sumif trên excel làm được đó mà..... Chứ còn nếu làm báo cáo hay gì đó thì lọc ra duy nhất rồi cộng lại là điều tất yếu rồi!

 

[Ba Tê]

Quan điểm của mình kết quả không đúng vì Tại cột J3 đến J14 các dữ liệu bị trùng do vật kết quản sumif() sẽ là 02 lần

Có nhiều lúc phải làm kiểu "Nguyễn Văn Mò" theo kết quả mẫu của người hỏi, còn đúng sai, xài vào chuyện gì thì là chuyện của người hỏi.
Híc!
Ngoài ấy đã lạnh chưa vậy Bình? Trong này sáng sớm "hơi bị mát" rồi.

 

[Hoàng Trọng Nghĩa]

Chưa hiểu lắm ý của bạn.
Chỉnh lại Sub của bạn, nếu đúng ý thì xài.

Bài của anh Ba thì OK rồi, nhưng nếu dữ liệu không quá 65 ngàn dòng thì thử dùng kiểu này (không liên quan đến file của tác giả) cho nó đơn giản!

Sub TEST()
    Dim r As Long
    Dim Dict As Object
    Dim f As WorksheetFunction
    Set f = WorksheetFunction
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim ArrData, ArrKetQua1, ArrKetQua2
    ArrData = Range("A3:B62")
    For r = 1 To UBound(ArrData)
        Dict(ArrData(r, 1)) = ArrData(r, 2) + Dict.Item(ArrData(r, 1))
    Next
    ArrKetQua1 = f.Transpose(Dict.Keys)
    ArrKetQua2 = f.Transpose(Dict.Items)
    With Range("I3").Resize(UBound(ArrKetQua1))
        .Value = ArrKetQua1
        .Offset(, 1) = ArrKetQua2
    End With
End Sub

Chỉ là một trong những thuật toán "chơi với đít-to" thui nhé!

 

[VetMini]

Nếu đơn giản thì 3 biến f, ArKetQua1, và ArrKetQua2 không cần thiết:

With Range("I3").Resize(Dict.Count, 2)
.Columns(1) = Application.Transpose(Dict.Keys)
.Columns(2) = Application.Transpose(Dict.Items)
End With