VBA 中的多维字典类

Question

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

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

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

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

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

下面的代码解决了这两个问题。 性能未经测试，但 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

Answer 1

代码更简单，但使用起来更难看：

嵌套字典.cls

Private m_vValue As Variant
Private m_oNext As Object

Private Sub Class_Initialize()
    Set m_oNext = CreateObject("Scripting.Dictionary")
End Sub

Public Property Get Value() As Variant
    If IsObject(m_vValue) Then
        Set Value = m_vValue
    Else
        Value = m_vValue
    End If
End Property

Public Property Let Value(vValue As Variant)
    m_vValue = vValue
End Property

Public Property Set Value(vValue As Variant)
    Set m_vValue = vValue
End Property

Public Property Get Item(ByRef vKey As Variant) As NestedDictionary
    If Not m_oNext.Exists(vKey) Then
        Set m_oNext.Item(vKey) = New NestedDictionary
    End If
    Set Item = m_oNext.Item(vKey)
End Property

测试：

Sub Test()
    Dim oDict As NestedDictionary
    
    Set oDict = New NestedDictionary
    oDict.Item(1).Item(2).Item(3).Value = 4
    oDict.Item(1).Item("Test").Value = "hehe"
    MsgBox oDict.Item(1).Item(2).Item(3).Value
    MsgBox oDict.Item(1).Item("Test").Value
End Sub