VBA Dictionaries

Question

I'm trying to create a dictionary of key:value pairs in VBA. The keys will be account IDs and the values should be lists of integers. Given the following data:

the dictionary should look like this: {'123':[3,5],'456':[4,7],'789':[6]}

The array used as a value in the key:value pair will be dynamic; we won't know in advance how large it will be. I'm much more familiar with how to do this in Python, but not VBA, which requires dynamic resizing of arrays. Here's my code so far:

Sub test()
    Dim dict As New Scripting.Dictionary
    Dim sht As Worksheet
    Set sht = Sheets("Sheet1")
    Dim x As Integer
    Dim accountID As Variant
    Dim transaction As Variant

    For x = 2 To 5
        accountID = sht.Cells(x, 1).Value
        transaction = sht.Cells(x, 2).Value
        'Test whether the account exists in the dictionary
        'If the account does not exist, add it along with its transaction value
        If Not dict.Exists(accountID) Then
            Dim arr() As Variant
            arr(0) = transaction
            dict.Add accountID, arr
        'If the account exists, update its value array to include the transaction value
        ElseIf dict.Exists(accountID) Then
            arrLen = UBound(arr) - LBound(arr) + 1
            ReDim Preserve arr(arrLen + 1)
            dict(accountID)(arrLen + 1) = transaction
        End If
    Next x
End Sub

It's bugging on the portion that modifies the array. How should this be changed?

Answer 1

Arrays stored as items in a dictionary don't like being directly written to. You need to write the dictionary item to a temporary array before setting the item back to the updated array.

Sub test()
    Dim dict As New Scripting.Dictionary
    Dim sht As Worksheet
    Dim x As Long
    Dim accountID As Variant, transaction As Variant
    Dim arr As Variant

    Set sht = Sheets("Sheet1")

    With sht
        For x = 2 To 6
            ReDim arr(0)
            accountID = .Cells(x, 1).Value2
            transaction = .Cells(x, 2).Value2
            With dict
                If Not .Exists(accountID) Then
                    ReDim arr(0)
                    arr(0) = transaction
                    .Add Key:=accountID, Item:=arr
                Else
                    arr = .Item(accountID)
                    ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
                    arr(UBound(arr)) = transaction
                    dict(accountID) = arr
                End If
            End With
        Next x
    End With


    ' Read back dictionary and array
    Dim k
    Dim dictStr As String
    dictStr = "{"
    For Each k In dict.Keys
        Debug.Print k, Join(dict(k), ", ")
        dictStr = dictStr & "'" & k & "':[" & Join(dict(k), ",") & "],"
    Next k
    dictStr = Left(dictStr, Len(dictStr) - 1) & "}"
    MsgBox dictStr

End Sub

This may be a more efficient way of achieving the same thing. This uses a couple of tricks using Index and Filter to Slice the arrays and filter a 2D array

Sub test()
    Dim arr As Variant, aKeys As Variant, aItems As Variant
    Dim dict As New Scripting.Dictionary
    Dim posArr As String
    Dim i As Long, k As Long

    With Sheets("Sheet1")
        arr = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))
    End With

    With Application
        ' Separates the arr array into two 1D arrays
        aKeys = .Transpose(.Index(arr, 0, 1))
        aItems = .Transpose(.Index(arr, 0, 2))

        ' Loops through aKeys array
        For i = LBound(aKeys) To UBound(aKeys)
            ' Reset the posArr string, this is used for indexing the arrays at the correct locations
            posArr = vbNullString
            ' Test if key already exists in dictionary. As we are getting all the possible values in one go we don't
            ' need to worry about if it does exist. Testing here means we skip the second loop if not needed
            If Not dict.Exists(aKeys(i)) Then
                ' Loop through aKeys to find all the positions of the items we want in the array
                For k = LBound(aKeys) To UBound(aKeys)
                    ' If the key in position k is equal to the key in position i then add it to posArr string
                    If aKeys(k) = aKeys(i) Then
                        ' We will late split this into an array itself on the "," delimiter
                        posArr = posArr & k & ","
                    End If
                Next k
                ' Add our key and all our matching items to the dictionary
                ' Here we split the posArr string on the "," delimiter and index the aItems array. This returns
                ' All the values from aItems that have a matching position in the aKeys array.
                ' For this to work it aKeys and aItems must have the exact same size (i.e. 1D and matching length)
                dict.Add Key:=aKeys(i), Item:=.Index(aItems, Split(Left(posArr, Len(posArr) - 1), ","))
            End If
        Next i
    End With


    ' Read back the dictionary
    ' Delete this and update with whatever you want to do with your data - This is currently just a check everything
    ' has worked as expected
    Dim dictKey
    Dim dictStr As String
    dictStr = "{"
    For Each dictKey In dict.Keys
        dictStr = dictStr & vbNewLine & vbTab & "'" & dictKey & "':[" & Join(dict(dictKey), ",") & "],"
    Next dictKey
    dictStr = Left(dictStr, Len(dictStr) - 1) & vbNewLine & "}"
    MsgBox dictStr
End Sub