VBA Excel：枚举重复的总数。 计数和总和

Question

On the left is the hypothetical database. On the right is the result I would like to obtain. I would like to print all of the items of type B, as well as the sum and the count. I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.

Private Sub CommandButton1_Click()

Dim dicDistincts As Scripting.Dictionary, _
    dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary

Dim i As Integer

For i = 2 To 10
    If Cells(i, 1).Value = "B" Then
        If Not dicDistincts.Exists(Cells(i, 2).Value) Then
        
            dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
        Else
        
            dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
        End If
    End If
Next i

For i = 0 To dicDuplicates.Count - 1
    Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i

End Sub

EDIT: I tried with countifs but it return 0 for banana, apple and strawberry

EDIT 2: I corrected the countifs. Now it works.

Answer 1

If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.

Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant

    Set dic = New Dictionary

    For i = 2 To 10
        If Cells(i, 1).Value = "B" Then
            ky = Cells(i, 2).Value
            If Not dic.Exists(ky) Then
                arrData = Array(1, Cells(i, 3).Value)
            Else
                arrData = dic(ky)
                arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
            End If
            dic(ky) = arrData
        End If
    Next i

    Range("A1:C1").Copy Range("E1:G1")
    For i = 0 To dic.Count - 1
        Range("E" & i + 2) = dic.Keys(i)
        Range("F" & i + 2).Resize(, 2) = dic.Items(i)
    Next i

End Sub

Answer 2

Unique Sum and Unique Count with Double Dictionary

Option Explicit

Private Sub CommandButton1_Click()

    Dim rg As Range
    With Range("A1").CurrentRegion
        Set rg = .Resize(.Rows.Count - 1).Offset(1)
    End With
    Dim Data As Variant: Data = rg.Value
    
    Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
    Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")

    Dim i As Long
    
    For i = 1 To UBound(Data, 1)
        If Data(i, 1) = "B" Then
            cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
            sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
        End If
    Next i
    
    ReDim Data(1 To cDict.Count, 1 To 3)
    i = 0
    
    Dim Key As Variant
    
    For Each Key In cDict.Keys
        i = i + 1
        Data(i, 1) = Key
        Data(i, 2) = sDict(Key)
        Data(i, 3) = cDict(Key)
    Next Key
    
    With Range("E2").Resize(, 3)
        .Resize(i).Value = Data
        .Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
    End With

End Sub

Answer 3

This should work it uses loops through all bs and addes them if to the other list

Sub countBs()


Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times

Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected


For Each B In Bs
    If B = "B" Then
        Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
        If adder Is Nothing Then
            If Range("g2") = "" Then
                Set Item = Range("g2")
            Else
                Set Item = Range("g1").End(xlDown).Offset(1, 0)
            End If
            Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
            Item.Offset(0, 2) = 1
        Else
            adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
            adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
        End If
    End If
Next B


End Sub