Question

我希望创建一个每个键包含多个项目的字典。以下是我现在正在使用的代码。我花了7个多小时玩字典，我似乎无法弄明白。我的范围输入中的唯一值作为我的字典的键是没有问题的，当我想要为每个键添加项时问题就出现了。如果密钥已经存在，我希望对该密钥的项目进行SUM（或添加），或者增加＆＃34; count＆＃34;该密钥将存储在该密钥的另一个项目中。也许通过视觉效果来解释它。

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

正如您所看到的，存在的所有唯一项都是作为自己的键创建的。如果密钥已存在，则将项目1添加到密钥的当前总计中，项目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(key) = d(key) + 1中的项目是d，那么您的代码Integer中就不会有d(key)。您必须将Collection的值读入临时变量，将其递增1，删除旧值，然后添加新的临时变量（如果Collections中的顺序为对你来说很重要的是你有一个更艰巨的任务）。但是，对象通过引用存储在这些类型的Collection中，因此您可以将该对象的属性修改为您心中的内容。

您注意到我Dictionary引用的Collection超过Collection。这是因为我认为您的要求更适合Runtime：a）我注意到您的原始数据可能非常大（可能超过3000项），我相信添加到cItems更快，b）你不会有引用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库的麻烦。

下面是一个类对象的示例，其中包含一些附加函数，以向您展示它是如何工作的。您可以使用 Insert~＆gt;在编辑器中创建它。课程模块我在名称属性窗口中调用了此课程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

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

NodeSLList & operator=(NodeSLList &list)

如果您想访问任何或所有项目，请执行以下操作：

list2

Answer 2

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

Answer 3

使用您的示例数据和类

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

Answer 4

解决方案类似于 @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

测试

VBA脚本字典，每个键有多个项目以及项目

4 个答案: