VBA code to find the sum of unique elements in a range

问题

I have 2 columns and need a VBA code to sum the values of unique elements in column "A", print the unique elements in column "D" and sum in column "E" :-

  Name  Value       Name    Sum
    A           1       A     13
    A           2       B      7
    B           1       C      3
    B           3           
    C           2           
    A           1           
    B           2           
    A           3           
    B           1           
    A           2           
    A           4           
    C           1           

Can anyone help on this, this is what I tried :-

Sub CountSum()
    Dim c As Collection, wf As WorksheetFunction, _
        K As Long, N As Long, i As Long, _
        v As Variant, d As Collection, y As Variant

    Set c = New Collection
    Set d = New Collection
    Set wf = Application.WorksheetFunction
    K = 2
    N = Cells(Rows.Count, "A").End(xlUp).Row
    On Error Resume Next

    For i = 2 To N
        v = Cells(i, "A").Value
        y = Cells(i, "B").Value
        c.Add v, CStr(v)
        d.Add y
        If Err.Number = 0 Then
            Cells(K, "D").Value = v
            Cells(K, "E").Value = wf.CountIf(Range("A:A"), v)
            Cells(K, "F").Value = wf.Sum(Range("B:B"), y)
            K = K + 1
        Else
            Err.Number = 0
        End If
    Next i
    On Error GoTo 0
End Sub

回答1:

Using a Dictionary:

Sub Tester()
    Dim rng As Range, dict As Object

    Set rng = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)

    Set dict = SubTotals(rng, 1, 2)
    DumpDict dict, Range("D1")

End Sub

Function SubTotals(rng As Range, colKey As Long, colVal As Long) As Object
    Dim rv As Object, rw As Range, k, v
    Set rv = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = rw.Cells(colKey).Value
        v = rw.Cells(colVal).Value
        If Not IsError(k) And Not IsError(v) Then
            If Len(k) > 0 And IsNumeric(v) Then
                rv(k) = rv(k) + v
            End If
        End If
    Next rw
    Set SubTotals = rv
End Function

Sub DumpDict(dict As Object, rng As Range)
    Dim i As Long, k
    i = 0
    For Each k In dict.keys
        With rng.Cells(1)
            .Offset(i, 0).Value = k
            .Offset(i, 1).Value = dict(k)
        End With
        i = i + 1
    Next
End Sub

回答2:

next code works for me, I hope this will help you. This will work perfectly if at column A there are not blank cells between values.

Sub SUM()

    Dim i, j, k As Integer
    i = 2
    j = 2

    Range("D1").Value = "NAME"
    Range("E1").Value = "VALUE"

    'copy the first value of column A to column D
    Range("D2").Value = Range("A2").Value

    'cycle to read all values of column B and sum it to column E; will run until find a blank cell
    While Range("A" & i).Value <> ""

        'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
        'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
        'in column D and E
        If Range("A" & i).Value = Range("A" & i - 1).Value Then
            Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
        Else
            flag = 1
            While Range("D" & flag).Value <> ""
                If Range("A" & i).Value = Range("D" & flag).Value Then
                    j = flag
                    Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
                    flag = Range("D1").End(xlDown).Row
                Else
                    j = 0
                End If
                flag = flag + 1
            Wend
            If j = 0 Then
                Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
                Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
                j = Range("E1").End(xlDown).Row
            End If
        End If

        i = i + 1
    Wend
    MsgBox "End"

End Sub

来源：https://stackoverflow.com/questions/26078463/vba-code-to-find-the-sum-of-unique-elements-in-a-range