Em không hiểu Dic.Item trong Scripting.dictionary mong chỉ giúp

[Lequocvan]

Sub test_buoc_4()
On Error Resume Next
Dim Arr(), ketqua()
Dim K As Long, J As Long

Dim Dic As Object
Dim dic2 As Object
Dim Contents As Variant
Dim ParentKeys As Variant
Dim ChildKeys As Variant
Dim R As Long, r2 As Long
Dim LastR As Long
Dim LastCol As Integer
Dim WriteStr As String

Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
' Dump the keys of the parent Dictionary in an array
With ThisWorkbook.ActiveSheet 'ThisWorkbook.Worksheets("212")

LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'MsgBox LastR
'MsgBox LastCol
'MsgBox ConvertToLetter(LastCol)
Contents = .Range("A2:" & ConvertToLetter(LastCol) & LastR).Value

ReDim ketqua(1 To UBound(Contents, 1), 1 To 3) '1 to 3: ket qua se cho hien ra o may cot
' Loop through the array
For R = 1 To UBound(Contents, 1) ''Chay tu dong 1 den dong cuoi cung

'dic.Add "Key " & r, "Item " & r
If Not Dic.Exists(Contents(R, 1)) Then

K = K + 1
Dic.Add Contents(R, 1), K

ketqua(K, 1) = Contents(R, 1)
ketqua(K, 2) = Contents(R, 7)​

Else

'MsgBox dic.Item(Contents(r, 1))
'Nếu muốn tính tổng theo giá trị duy nhất Key thì đặt công thức ntn ah? ​

End If​

Next
'MsgBox UBound(Contents, 1) 'cho biet SoDong trong mang du lieu
'MsgBox Join(dic.Keys(), ";") 'MsgBox Join(dic.Keys(), vbNewLine)
'MsgBox Join(dic.Items(), ";")

'MsgBox k 'k chinh la so luong gia tri duy nhat, khi co them dong code:dic.Add Contents(r, 1), k


Range("I:J").Select
Selection.ClearContents
Range("I1").Select
Range("I2").Resize(1000, 4).Clear
Range("I2").Resize(K, 2).Value = ketqua
Range("J:J").Select
Selection.NumberFormat = "#,##0"


​

End With
End Sub
Function ConvertToLetter(iCol As Integer) As String
'from Microsoft 'Tu so thu tu cua cot cho ra ten chu cai cua cot do
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function

 

[RoberLiem]

Chỗ cái dòng màu đỏ:
ketqua(Dic.Item(Contents(R, 1)), 2) = ketqua(Dic.Item(Contents(R, 1)), 2) + Contents(R, 7)

 

[Lequocvan]

Dạ cảm ơn RoberLiem, chuẩn!
Qua đây Bác có thể giải thích chi tiết giúp em được không ah?

 

[Lequocvan]

Nếu như em muốn đếm số lần xuất hiện của 12 (ví dụ) thì thêm code ntn ah!?

 

[RoberLiem]

Nếu như em muốn đếm số lần xuất hiện của 12 (ví dụ) thì thêm code ntn ah!?

Bạn xem thử Sub này và sub test_buoc_4() của bạn xem kết quả thế nào.

Public Sub GPE_Test()
Dim Dic As Object, sArr(), dArr(), I As Long,  K As Long, R As Long, Rws As Long, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("212")
    sArr = .Range("A2", .Range("A2").End(xlDown)).Resize(, 7).Value
    R = UBound(sArr, 1)
    ReDim dArr(1 To R, 1 To 3)
    For I = 1 To R
        Tem = sArr(I, 1)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Item(Tem) = K
            dArr(K, 1) = Tem
            dArr(K, 2) = sArr(I, 7)
            dArr(K, 3) = 1
        Else
            Rws = Dic.Item(Tem)
            dArr(Rws, 2) = dArr(Rws, 2) + sArr(I, 7)
            dArr(Rws, 3) = dArr(Rws, 3) + 1
        End If
    Next I
    .Range("I2").Resize(K, 3) = dArr
    .Range("I2").Resize(K, 3).Sort Key1:=.Range("I2")
End With
Set Dic = Nothing
End Sub

 

[Lequocvan]

Cảm ơn Bác, em tuỳ biến và thử các kiểu đã được, nhưng nói thiệt là em chưa hiểu làm, vẫn phải đọc lại bài của Kyo ah

 

[befaint]

chưa hiểu

Thử đọc bài này xem dễ hiểu hơn không?