VBA map implementation

Question

I need good map class implementation in VBA. This is my implementation for integer key

Box class:

Private key As Long 'Key, only positive digit
Private value As String 'Value, only 

'Value getter
Public Function GetValue() As String
    GetValue = value
End Function

'Value setter
Public Function setValue(pValue As String)
    value = pValue
End Function

'Ket setter
Public Function setKey(pKey As Long)
    Key = pKey
End Function

'Key getter
Public Function GetKey() As Long
    GetKey = Key
End Function

Private Sub Class_Initialize()

End Sub

Private Sub Class_Terminate()

End Sub

Map class:

Private boxCollection As Collection

'Init
Private Sub Class_Initialize()
    Set boxCollection = New Collection
End Sub

'Destroy
Private Sub Class_Terminate()
    Set boxCollection = Nothing
End Sub

'Add element(Box) to collection
Public Function Add(Key As Long, value As String)
    If (Key > 0) And (containsKey(Key) Is Nothing) Then
    Dim aBox As New Box
    With aBox
       .setKey (Key)
       .setValue (value)
    End With
    boxCollection.Add aBox
    Else
       MsgBox ("В словаре уже содержится элемент с ключем " + CStr(Key))
    End If
End Function

'Get key by value or -1
Public Function GetKey(value As String) As Long
    Dim gkBox As Box
    Set gkBox = containsValue(value)
    If gkBox Is Nothing Then
        GetKey = -1
    Else
        GetKey = gkBox.GetKey
    End If
End Function

'Get value by key or message
Public Function GetValue(Key As Long) As String
    Dim gvBox As Box
    Set gvBox = containsKey(Key)
    If gvBox Is Nothing Then
        MsgBox ("Key " + CStr(Key) + " dont exist")
    Else
        GetValue = gvBox.GetValue
    End If
End Function

'Remove element from collection
Public Function Remove(Key As Long)
    Dim index As Long
    index = getIndex(Key)
    If index > 0 Then
        boxCollection.Remove (index)
    End If
End Function


'Get count of element in collection
Public Function GetCount() As Long
    GetCount = boxCollection.Count
End Function

'Get object by key
Private Function containsKey(Key As Long) As Box
    If boxCollection.Count > 0 Then
           Dim i As Long
           For i = 1 To boxCollection.Count
             Dim fBox As Box
             Set fBox = boxCollection.Item(i)
             If fBox.GetKey = Key Then Set containsKey = fBox
          Next i
       End If
End Function

'Get object by value
Private Function containsValue(value As String) As Box
       If boxCollection.Count > 0 Then
           Dim i As Long
           For i = 1 To boxCollection.Count
             Dim fBox As Box
             Set fBox = boxCollection.Item(i)
             If fBox.GetValue = value Then Set containsValue = fBox
          Next i
       End If
End Function

'Get element index by key
Private Function getIndex(Key As Long) As Long
    getIndex = -1
    If boxCollection.Count > 0 Then
           For i = 1 To boxCollection.Count
             Dim fBox As Box
             Set fBox = boxCollection.Item(i)
             If fBox.GetKey = Key Then getIndex = i
          Next i
       End If
End Function

All ok if i insert 1000 pairs key-value. But if 50000, a program freezes.

How i can solve this problem? Or maybe there more better solution?

score 2 · Accepted Answer · edited May 23 '17 at 11:50

Main problem with your implementation is that the operation containsKey is quite expensive (O(n) complex) and it is called at every insert and it never breaks even when it "knows" what would be the result.

This might help a little:

...
If fBox.GetKey = Key Then
    Set containsKey = fBox
    Exit Function
End If
...

In order to reduce the containsKey complexity typical things to do would be

keep the keys sorted so that you can use binary search instead of linear search
keep the keys in tree or in a hashed buckets

The most straightforward thing to do would be using the Collection's built-in (hopefully optimized) ability to store/retrieve items by a key.

Store:

...
boxCollection.Add Item := aBox, Key := CStr(Key)
...

Retrieve (not tested, based on this answer):

Private Function containsKey(Key As Long) As Box
    On Error GoTo err
        Set containsKey = boxCollection.Item(CStr(Key))
        Exit Function
    err:
        Set containsKey = Nothing
End Function

VBA map implementation

1 Answers1