如何按类别对行值求和

Question

So I have got the following table in Excel for example (it actually has 100+ rows):

Alfa     10
Beta     5
Alfa     10
Beta     5
Gama     15

What I would like to do is SUM values by the name (category) using VBA Macro, so I can display it somewhere in the Sheet like this:

AlfaTotal     20
BetaTotal     10
GamaTotal     15

I have tried using For Each function but am not able to get to the values. Any help would be much appreciated.

Answer 1

Using a dictionary is a common method. The below handles blanks in range, also if only 1 item present. It doesn't need an .Exists test as simply adds to any existing value by direct access. Also, writes arrays of keys, items out in one go.

Option Explicit
Public Sub GetTotals()
    Dim dict As Object, arr(), i As Long, lastRow As Long
    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Sheet1")       '<==source data
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Select Case lastRow
        Case 1
            ReDim arr(1, 1): arr(1, 1) = .Range("A1:B1").Value
        Case Else
            arr = .Range("A1:B" & lastRow).Value
        End Select
    End With

    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not IsEmpty(arr(i, 1)) Then
            dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, 2)
        End If
    Next
    With ThisWorkbook.Worksheets("Sheet2")
        .Range("A1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.keys)
        .Range("B1").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.Items)
    End With
End Sub

---

Results:

Answer 2

If you don't know how many categories you'll have before trying to sum them, something like this could be a solution:

Option Explicit

Sub test()
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")

    Dim s As String, key_value As String
    Dim v As Variant
    Dim num As Long

    Dim r As Range, c As Range
    Set r = Sheet1.Range(Sheet1.Range("A2"), Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp))

    For Each c In r
        key_value = CStr(c)
        num = CLng(c.Offset(0, 1))

        If d.Exists(key_value) Then
            d(key_value) = d(key_value) + num
        Else
            d.Add Key:=key_value, Item:=num
        End If
    Next c

    For Each v In d
        s = s & CStr(v) & vbTab & CStr(d(v)) & vbLf
    Next v

    MsgBox prompt:=s, Title:="Summation", Buttons:=vbInformation
End Sub

If you know what categories you'll have in advance, just making some sumif formulas based on those would probably be simpler.