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

Question

我希望创建一个每个键包含多个项目的字典。下面是我现在正在使用的代码。我已经花了 7 个多小时摆弄字典，但我似乎无法弄清楚。我可以毫无问题地从范围输入中获取唯一值作为字典的键，但当我想向每个键添加项目时，问题就出现了。如果该键已经存在，我想对该键的项目进行求和(或添加)，或者增加该键的“计数”，该计数将存储在该键的另一个项目中。也许通过视觉效果来解释是最好的。

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

正如您所看到的，所有存在的唯一项目都被创建为其自己的 key 。如果该键已存在，则 Item1 将添加到该键的当前总数中，第 2 项有一个计数，并且该计数增加 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

Answer 1

类对象非常适合此任务。一方面，您可以创建自己的数据字段，另一方面，您可以添加更多功能(例如，存储每个单独的项目或具有平均总和和计数的函数)，最重要的是，您可以对字段执行算术函数(例如作为补充)。

后者非常有用，因为原始数据类型无法在 Collection 类型的对象中修改。例如，如果 d 中的项目是一个 Integer<，那么您的代码中就不能包含 d(key) = d(key) + 1/。您必须将 d(key) 的值读入临时变量，将其增加 1，删除旧值，然后添加新的临时变量(如果 中的顺序>收藏对你来说很重要，那么你的任务就更艰巨了)。但是，对象是通过引用存储在这些类型的集合中，因此您可以根据自己的喜好修改该对象的属性。

您会注意到，我引用 Collection 的次数多于引用 Dictionary 的次数。这是因为我认为您的要求更适合 Collection:a) 我注意到您的原始数据可能非常大(可能超过 3000 个项目)，并且我相信添加到 >Collection 更快，而且 b) 您不会有引用 Runtime 库的麻烦。

下面是一个类对象的示例，它带有几个附加函数，向您展示它是如何工作的。您可以在编辑器中使用插入〜>类模块创建它，我在名称属性窗口中将此类称为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