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

VBA scripting dictionary, multiple items per key and sum/count on items

提问by Citanaf

I am wishing to create a dictionary with multiple items per key. Below is the code I am working with now. I've spend over 7 hours playing with the dictionary and I can't seem to figure it out. I have no problem getting the unique values from a my range input as keys to my dictionary, the problem comes when I want to add items to each key. If the key already exists, I would like to SUM (or add) to that key's item's, or increase the "count" for that key, which would be stored in another item of that key. Perhaps it's best explained through visuals.

我希望创建一个每个键有多个项目的字典。下面是我现在正在使用的代码。我花了超过 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

So as you can see, all unique items that exist are created as their own key. If the key already exists, Item1 is added to the key's current total, item 2 has a count and that is increased by 1. Below is the code I'm working with, I appreicate your assistance.

如您所见，所有存在的唯一项都被创建为它们自己的键。如果密钥已经存在，则 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

采纳答案by Ambie

A class object is ideal for this task. For one thing you can create your own data fields, for another you can add further functionality (eg store each individual item or have a function that averages the sum and count) and, most importantly, you can perform arithmetic functions on the fields (such as addition).

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

The latter is very useful because primitive data types cannot be amended in a Collectiontype of object. For example you couldn't have in your code d(key) = d(key) + 1if the item in dis, say, an Integer. You'd have to read the value of d(key)into a temporary variable, increment that by 1, remove the old value and then add the new temporary variable (and if the order in the Collectionis important to you then you have an even tougher task). However, objects are stored by reference in these types of Collections, so you can amend the properties of that object to your heart's content.

后者非常有用，因为不能在Collection对象类型中修改原始数据类型。例如，d(key) = d(key) + 1如果项目中的项目d是Integer. 您必须将 的值读d(key)入临时变量，将其增加 1，删除旧值，然后添加新的临时变量（如果 中的顺序Collection对您很重要，那么您将面临更艰巨的任务）。但是，对象通过引用存储在这些类型的 中Collections，因此您可以修改该对象的属性以满足您的需求。

You'll note that I've been referencing Collectionmore than Dictionary. This is because I think your requirements are better suited to a Collection: a) I note your raw data could be quite large (perhaps in excess of 3000 items), and I believe that adding to a Collectionis quicker, and b) you wouldn't have the hassle of referencing the Runtimelibrary.

你会注意到我引用的Collection不仅仅是Dictionary. 这是因为我认为您的要求更适合 a Collection:a) 我注意到您的原始数据可能非常大（可能超过 3000 个项目），并且我相信添加到 aCollection会更快，并且 b）您不会有参考Runtime图书馆的麻烦。

Below is an example of a class object with a couple of additional functions to show you how it could work. You create it in your editor with Insert ~> Class ModuleI've called this class cItemsin the Nameproperties window:

下面是一个带有几个附加函数的类对象的示例，向您展示它是如何工作的。您在编辑器中使用Insert ~> Class Module创建它我cItems在Name属性窗口中调用了这个类：

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

You would then add the items to your collection in your main module as follows:

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

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

If you wanted to access any or all of the items you'd do it like so:

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

'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

回答by Ambie

I use a method of joining multiple values into a single .Itemwith a rarely-encountered delimiter. The .Itemcan be split and have its elements adjusted as the dictionary is constructed.

我使用一种方法将多个值连接到一个.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

Results from the VBE's Immediate window:

VBE 立即窗口的结果：

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

回答by Tim Williams

Using your sample data and a class

使用您的示例数据和一个类

clsItem:

cls 项目：

Public Sum As Double
Public Count As Long

Module:

模块：

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

回答by Vasily

solution is similar with@Jeepedanswer, but has some difference.

解决方案与@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

---

---

test

测试