VBA脚本字典，每个键有多个项，项的总和/计数

我希望创建一个字典，每个键有多个项目。下面是我现在正在使用的代码。我花了7个多小时在玩这本字典，但我似乎弄不懂。我可以从my range输入中获取唯一值作为字典的键，当我想向每个键添加项时，问题就出现了。如果该键已经存在，我希望对该键的项进行求和（或添加），或者增加该键的“计数”，这将存储在该键的另一项中。也许最好通过视觉效果来解释

Key        Item1      Item2
PersonA    20         SomeOtherVal
PersonB    40         SomeOtherVal
PersonA    80         SomeOtherVal
PersonB    17         SomeOtherVal
PersonC    13         SomeOtherVal

Result:
Key        Item1(Sum) Item2(Count)
PersonA    100        2
PersonB    57         2
PersonC    13         1

如您所见，所有存在的唯一项都被创建为它们自己的键。如果密钥已经存在，则将Item1添加到密钥的当前总数中，Item2有一个计数，该计数增加1。下面是我正在使用的代码，我感谢您的帮助

Sub dictionaryCreate()

Dim Pair As Variant
Dim q As Range
Dim RAWDATA As Range

Dim d As Dictionary                             'Object
Set d = New Dictionary                          'CreateObject("Scripting.Dictionary")

Set RAWDATA = Worksheets("RAW_DATA").Range(Cells(2, 1), Cells(3000, 1))
For Each q In RAWDATA
    Pair = q.Offset(0, 60).Value + q.Offset(0, 65).Value
    If d.Exists(Pair) Then
        'ADD to item1 SUM
        'Add to item2 COUNT
    Else
        d(Pair) = 1 'create new key
    End If
Next

End Sub

---

我使用一种方法将多个值连接到一个

.Item

，并使用一个很少遇到的分隔符。可以拆分

.Item

，并在构建字典时调整其元素

Sub dictionaryCreate()

    Dim rw As Long, vITM As Variant, vKEY As Variant
    Dim d As New Dictionary   ' or Object & CreateObject("Scripting.Dictionary")

    d.CompareMode = vbTextCompare

    With Worksheets("RAW_DATA")
        For rw = 2 To 3000   'maybe this ~> .Cells(Rows.Count, 1).End(xlUp).Row
            If d.Exists(.Cells(rw, 1).Value2) Then
                vITM = Split(d.Item(.Cells(rw, 1).Value2), ChrW(8203))
                d.Item(.Cells(rw, 1).Value2) = _
                    Join(Array(vITM(0) + .Cells(rw, 2).Value2, vITM(1) + 1), ChrW(8203))  'modify and join on a zero-width space
            Else
                d.Add Key:=.Cells(rw, 1).Value2, _
                      Item:=Join(Array(.Cells(rw, 2).Value2, 1), ChrW(8203))  'join on a zero-width space
            End If
        Next rw
    End With

    Debug.Print "key" & Chr(9) & "sum" & Chr(9) & "count"
    For Each vKEY In d.Keys
        Debug.Print vKEY & Chr(9) & _
                    Split(d.Item(vKEY), ChrW(8203))(0) & Chr(9) & _
                    Split(d.Item(vKEY), ChrW(8203))(1)
    Next vKEY

    d.RemoveAll: Set d = Nothing

End Sub

来自VBE即时窗口的结果：

key     sum count
PersonA 100 2
PersonB 57  2
PersonC 13  1

---

使用示例数据和类

clsItem：

Public Sum As Double
Public Count As Long

模块：

Sub dictionaryCreate()

    Dim Pair As Variant
    Dim q As Range, v, k
    Dim RAWDATA As Range

    Dim d As Dictionary
    Set d = New Dictionary

    Set RAWDATA = [A2:A6]
    For Each q In RAWDATA
        Pair = q.Value
        v = q.Offset(0, 1).Value 'get the value to be added...
        If d.Exists(Pair) Then
            d(Pair).Sum = d(Pair).Sum + v
            d(Pair).Count = d(Pair).Count + 1
        Else
            d.Add Pair, NewItem(v)
        End If
    Next

    'print out dictionary content
    For Each k In d
        Debug.Print k, d(k).Sum, d(k).Count
    Next k
End Sub

Function NewItem(v) As clsItem
    Dim rv As New clsItem
    rv.Sum = v
    rv.Count = 1
    Set NewItem = rv
End Function

---

类对象非常适合于此任务。一方面，您可以创建自己的数据字段；另一方面，您可以添加进一步的功能（例如存储每个单独的项或使用一个求和和和计数平均值的函数），最重要的是，您可以对字段执行算术功能（例如加法）

后者非常有用，因为在对象的

集合

类型中不能修改基本数据类型。例如，如果

d

中的项是一个

整数，则代码中不能有
d（key）=d（key）+1
。您必须将
d（key）
的值读入一个临时变量，将其递增1，删除旧值，然后添加新的临时变量（如果
集合中的顺序对您很重要，那么您的任务就更艰巨了）。但是，对象通过引用存储在这些类型的
集合中
，因此您可以根据自己的内心内容修改该对象的属性

您会注意到，我所引用的
Collection
多于
Dictionary
。这是因为我认为您的需求更适合于
集合
：a）我注意到您的原始数据可能相当大（可能超过3000项），并且我相信添加到
集合
会更快，b）您不会有麻烦地引用
运行时
库

下面是一个类对象的示例，其中包含两个附加函数，向您展示了它是如何工作的。您可以使用Insert~>Class模块在编辑器中创建它，我在名称属性窗口中调用了这个类
cItems
：

Public Key As String
Public Sum As Long
Public Count As Long
Public ItemList As Collection
Public Function Mean() As Double
    Mean = Sum / Count
End Function
Private Sub Class_Initialize()
    Sum = 0
    Count = 0
    Set ItemList = New Collection
End Sub

然后，将项目添加到主模块中的集合中，如下所示：

Dim col As Collection
Dim dataItems As cItems
Dim itemKey As String
Dim item1 As Long
Dim ws As Worksheet
Dim r As Long

Set ws = ThisWorkbook.Worksheets("RAW_DATA")
Set col = New Collection

For r = 2 To 3000
    itemKey = CStr(ws.Cells(r, "A").Value2) '~~adjust to your own column(s)
    item1 = CLng(ws.Cells(r, "B").Value2) '~~adjust to your own column(s)

    'Check if key already exists
    Set dataItems = Nothing: On Error Resume Next
    Set dataItems = col(itemKey): On Error GoTo 0

    'If key doesn't exist, create a new class object
    If dataItems Is Nothing Then
        Set dataItems = New cItems
        dataItems.Key = itemKey
        col.Add dataItems, itemKey
    End If

    'Add cell values to the class object
    With dataItems
        .Sum = .Sum + item1
        .Count = .Count + 1
        .ItemList.Add item1
    End With

Next

如果您想访问任何或所有项目，您可以这样做：

'Iterating through all of the items
For Each dataItems In col
    Debug.Print dataItems.Mean
Next

'Selecting one item
Set dataItems = col("PersonA")
Debug.Print dataItems.Mean

解决方案与@Jeeped答案类似，但有一些不同。


试验

@Tim Williams，对不起，没有看到你的答案。我猜整个类的事情对我们所有人都有影响。没关系，我没意识到你必须命名你的类模块。。testingOk，我最终使用了你的代码，效果很好。我现在有一个集合，其中包含和itemlist以及每个项目的总和/计数。努力掌握课程的诀窍，但我还有很多东西要补充，所以这是一个很好的开始。Thanks@Citanaf建议访问此页面嗨Tim，谢谢你的回答，这对理解课堂模块的工作原理很有用。嗨Jeeped，感谢你的回答。我继续使用上面的代码组合，因为它们在我所寻找的内容中更直接一些。再次感谢！
Sub test()
    Dim i, cl As Range, Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    For Each cl In Sheets("RAW_DATA").[A2:A6]
        If Not Dic.Exists(cl.Value) Then
            Dic.Add cl.Value, cl.Offset(, 1).Value2 & "|" & 1
        Else
            Dic(cl.Value) = Split(Dic(cl.Value), "|")(0) + cl.Offset(, 1).Value2 & _
                        "|" & Split(Dic(cl.Value), "|")(1) + 1
        End If
    Next cl
    Debug.Print "Key", "Sum", "Count"
    For Each i In Dic
        Debug.Print i, Split(Dic(i), "|")(0), Split(Dic(i), "|")(1)
    Next i
End Sub