VBA代码可查找范围内唯一元素的总和

问题描述

我有2列，并且需要VBA代码来对"A"列中唯一元素的值求和，在"D"列中打印唯一元素并在"E"列中求和:-

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

推荐答案

使用字典:

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

这篇关于VBA代码可查找范围内唯一元素的总和的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！