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

Question

我希望创建一个每个键有多个项目的字典.以下是我现在正在使用的代码.我花了7个多小时玩字典,我似乎无法弄明白.我的范围输入中的唯一值作为我的字典的键是没有问题的,当我想要为每个键添加项时问题就出现了.如果密钥已经存在,我想对该密钥的项目进行SUM(或添加),或者增加该密钥的"计数",该密钥将存储在该密钥的另一个项目中.也许通过视觉效果最好地解释.

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添加到密钥的当前总计中,项目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)入临时变量,将其递增1,删除旧值,然后添加新的临时变量(如果订单中的顺序Collection对您很重要,那么您的任务更加艰难).但是,对象通过引用存储在这些类型中Collections,因此您可以将该对象的属性修改为您的内容.

你会注意到我参考的Collection不仅仅是Dictionary.这是因为我认为你的要求更适合于Collection:a)我注意到你的原始数据可能非常大(可能超过3000项),我相信加入a Collection更快,而且b)你不会有引用Runtime库的麻烦.

下面是一个类对象的示例,其中包含一些附加函数,以向您展示它是如何工作的.你可以在编辑器中用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

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

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

Answer 2

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

cls 项目：

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