VBA 中的多维 Dictionary 类

问：

这篇文章一半是分享解决方案，一半是询问是否有更好的方法。

问题：如何在VBA中构建多维词典。

似乎有人在寻找一个，但没有一个明显的简洁解决方案，所以我想出了一些代码，如下所示。

具体情况：将 ADO 记录集转换为字典，其中几列组成行的唯一键。将多条记录添加到同一词典将失败，除非您想出一个键来连接组成唯一键的所有列。

一般情况：对对象层次结构中的树结构进行建模，其中层次结构中同一级别的每个节点的分支数量可能不同。

下面的代码解决了这两个问题。性能未经测试，但 VBA 脚本库的 Dictionary 类显然是用哈希表索引的，我见过用它构建的非常大的系统，所以我怀疑性能会是一个问题。也许那里的一个大脑会纠正我。

将其放入名为 multiDictionary 的 VBA 类中：

Option Explicit

' generic multi-dimensional dictionary class
' each successive higher dimension dictionary is nested within a lower dimension dictionary
Private pDictionary As Dictionary
Private pDimensionKeys() As Variant

Private Const reservedItemName As String = "multiItem"

Public Function add(value As Variant, ParamArray keys() As Variant)
    Dim searchDictionary As Dictionary
    Dim newDictionary As Dictionary
    Dim count As Long
    If pDictionary Is Nothing Then Set pDictionary = New Dictionary
    Set searchDictionary = pDictionary
    For count = LBound(keys) To UBound(keys)
        If keys(count) = reservedItemName Then Err.Raise -1, "multiDictionary.add", "'" & reservedItemName & "' is a reserved key and cannot be used"
        If searchDictionary.Exists(keys(count)) Then
            Set newDictionary = searchDictionary.item(keys(count))
        Else
            Set newDictionary = New Dictionary
            searchDictionary.add key:=keys(count), item:=newDictionary
        End If
        Set searchDictionary = searchDictionary.item(keys(count))
    Next
    ' each node can have only one item, otherwise it has dictionaries as children
    searchDictionary.add item:=value, key:=reservedItemName
End Function

Public Function item(ParamArray keys() As Variant) As Variant
    Dim count As Long
    Dim searchDictionary As Dictionary
    Set searchDictionary = pDictionary
    For count = LBound(keys) To UBound(keys)
        ' un-nest iteratively
        Set searchDictionary = searchDictionary.item(keys(count))
    Next
    ' the item always has the key 'reservedItemName' (by construction)
    If IsObject(searchDictionary.item(reservedItemName)) Then
        Set item = searchDictionary.item(reservedItemName)
    Else
        item = searchDictionary.item(reservedItemName)
    End If
End Function

并像这样测试它

Sub testMultiDictionary()
    Dim MD As New multiDictionary
    MD.add "Blah123", 1, 2, 3
    MD.add "Blah124", 1, 2, 4
    MD.add "Blah1234", 1, 2, 3, 4
    MD.add "BlahXYZ", "X", "Y", "Z"
    MD.add "BlahXY3", "X", "Y", 3
    Debug.Print MD.item(1, 2, 3)
    Debug.Print MD.item(1, 2, 4)
    Debug.Print MD.item(1, 2, 3, 4)
    Debug.Print MD.item("X", "Y", "Z")
    Debug.Print MD.item("X", "Y", 3)
End Sub