# Structured Set of Dictionaries for Table Lookups

Somewhat recently I encountered an issue where my projects were simply taking to long to run. A lot of my macro work comes down to taking multiple tables (generally formatted in the same way) and joining together these tables based on specific users. This led to instances of loops that would loop over one table nearly 100k times, searching for a value in a table of a similar size and it would do so repeatedly (10 times or more).

I ended up developing the class below for this task, but I am certain that there are things I simply don't know, or could do better. What this class does is basically provide a Dictionary with some additional methods that allow me input tables and return a Dictionary I can retrieve values from.

The main reason why I built the class was that I didnt want to keep writing loops that would simply loop over a table and add a dictionary with the only differences being the number of dimensions I needed.

I hope this all makes sense. Any advice is appreciated!

Option Explicit
Private pCollector As Object
Private pHierarchy As Variant
Private pDirtyHierarchy As Boolean
Private pKeyCollection As Variant
Private Sub Class_Initialize()
Set pCollector = CreateObject("Scripting.Dictionary")
pCollector.CompareMode = 1
End Sub
Public Property Get Collector()
Set Collector = pCollector
End Property
Public Property Get Hierarchy()
Hierarchy = pHierarchy
End Property
Public Property Get DirtyHierarchy()
DirtyHierarchy = pDirtyHierarchy
End Property
Public Property Let KeyCollection(value As Object)
Set pKeyCollection = value
End Property
Public Property Get KeyCollection() As Object
Set KeyCollection = pKeyCollection
End Property
Public Function IsSearchable(value As Variant)
If TypeName(value) = "cSearchableDataset" Then
IsSearchable = True
Else
IsSearchable = False
End If
End Function
Public Sub Switch_CompareMode(Optional Overwrite As Boolean = False)
Dim lHolder As ComparisonType
If pCollector.Count > 0 And Not Overwrite Then
Exit Sub
Else
lHolder = pCollector.CompareMode
If lHolder = Text Then
lHolder = Binary
Else
lHolder = Text
End If
Set pCollector = CreateObject("Scripting.Dictionary")
pCollector.CompareMode = lHolder
End If
pDirtyHierarchy = True
End Sub
Public Function Item(args As Variant, Optional lLevel As Long = 0) As Variant
If lLevel = 0 Then lLevel = LBound(args)
If Not IsArray(args) Then
If pCollector.Exists(args) Then
If IsObject(pCollector(args)) Then
Set Item = pCollector(args)
Else
Item = pCollector(args)
End If
End If
Else
If lLevel = UBound(args) Then
If pCollector.Exists(args(lLevel)) Then
If IsObject(pCollector(args(lLevel))) Then
Set Item = pCollector(args(lLevel))
Else
Item = pCollector(args(lLevel))
End If
End If
Else
If IsSearchable(pCollector(args(lLevel))) Then
If IsObject(pCollector(args(lLevel)).Item(args, lLevel + 1)) Then
Set Item = pCollector(args(lLevel)).Item(args, lLevel + 1)
Else
Item = pCollector(args(lLevel)).Item(args, lLevel + 1)
End If
Else
If IsObject(pCollector(args(lLevel))) Then
Set Item = pCollector(args(lLevel))
Else
Item = pCollector(args(lLevel))
End If
End If
End If
End If
End Function
Public Function Items() As Variant
Items = pCollector.Items
End Function
Public Function Keys() As Variant
Keys = pCollector.Keys
End Function
Public Function HashItems() As Variant
Dim arrKeys As Variant
Dim arrItems As Variant
Dim arrHolder As Variant

Dim i As Long

arrKeys = pCollector.Keys
arrItems = pCollector.Items

ReDim arrHolder(LBound(arrKeys) To UBound(Keys), 1 To 2)
For i = LBound(arrHolder, 1) To UBound(arrHolder, 1)
arrHolder(i, 1) = Keys(i)
If IsObject(arrItems(i)) Then
Set arrHolder(i, 2) = Items(i)
Else
arrHolder(i, 2) = Items(i)
End If
Next

HashItems = arrHolder
End Function
Public Sub Add(ByVal sKey As String, oItem As Variant, Optional bOverwrite As Boolean = False)
If Not pCollector.Exists(sKey) Then
ElseIf bOverwrite Then
pCollector.Item = oItem
End If
pDirtyHierarchy = True
End Sub
Public Sub Remove(ByVal sKey As String)
If pCollector.Exists(sKey) Then
pCollector.Remove (sKey)
End If
pDirtyHierarchy = True
End Sub
Public Function Exists(ByVal sKey As String)
If pCollector.Exists(sKey) Then _
Exists = True
End Function
Public Function Count()
Count = pCollector.Count
End Function
Public Function Get_Max_Depth() As Long
Dim vKey As Variant
Dim lHolder As Long
For Each vKey In pCollector.Count
If TypeName(pCollector(vKey)) = "cSearchableDataset" Then
lHolder = pCollector(vKey).Get_Max_Depth
Exit For
End If
Next

If lHolder = 0 Then
Get_Max_Depth = 1
Else
Get_Max_Depth = lHolder + 1
End If
End Function
Public Function List_Collection() As Variant
Dim vKey As Variant
Dim arrKeys As Variant
Dim arrItems As Variant

Dim arrHolder As Variant
Dim i As Long

If pCollector.Count > 0 Then
ReDim arrHolder(1 To pCollectorCount, 1 To 3)
arrKeys = pCollector.Keys
arrItems = pCollector.Items

For i = LBound(arrKeys) To UBound(arrKeys)
arrHolder(i + 1, 1) = arrKeys(i)
arrHolder(i + 1, 2) = TypeName(arrItems(i))
If TypeName(arrItems(i)) = "cSearchableDataset" Then
If arrItems(i).DirtyHierarchy Then
arrHolder(i + 1, 3) = arrItems(i).List_Collection
Else
arrHolder(i + 1, 3) = arrItems(i).Hierarchy
End If
ElseIf IsObject(arrItems(i)) Then
Set arrHolder(i + 1, 3) = arrItems(i)
Else
arrHolder(i + 1, 3) = arrItems(i)
End If
Next
End If
List_Collection = arrHolder
pHierarchy = arrHolder
pDirtyHierarchy = False
End Function
Public Sub Insert_Item(arr As Variant, lDepth As Long, Optional lLevel = 0)
Dim i As Long
Dim j As Long
Dim sHolder As String

If lLevel = 0 Then lLevel = LBound(arr, 1)
If pCollector.Exists(arr(lLevel, 1)) Then
If lLevel + 1 <= lDepth Then
pCollector(arr(lLevel, 1)).Insert_Item arr, lDepth, lLevel + 1
Else
For j = LBound(arr, 1) To UBound(arr, 1)
sHolder = sHolder & arr(j, 1)
If j <> UBound(arr, 1) Then sHolder = sHolder & " >>> "
Next
Debug.Print "Unable to add " & sHolder
End If
Else
pCollector.Add arr(lLevel, 1), arr(lLevel, 2).Collector(arr(lLevel, 1))
End If
End Sub
Public Sub Add_ParseItem(arr As Variant, ByVal EmailVal As Variant, ByVal IDVal As Variant, sKey As String)
Dim i As Long

Dim oFullParser As New cSearchableDataset
Dim oPartParser As New cSearchableDataset
Dim oMainDict As New cSearchableDataset

Dim oKeyHolder As Variant
Dim arrHolder As Variant

Set oKeyHolder = CreateObject("Scripting.Dictionary")

For i = LBound(arr, 2) To UBound(arr, 2)
If Not oKeyHolder.Exists(arr(LBound(arr, 1), i)) Then _
oKeyHolder.Add (arr(LBound(arr, 1), i)), i
Next

If TypeName(EmailVal) = "String" Then
If oKeyHolder.Exists(EmailVal) Then
EmailVal = oKeyHolder(EmailVal)
Else
' I still need to create a way of setting an accurate default value here.
Debug.Print "EmailVal not set properly. Exiting 'Add_ParseItem'."
Exit Sub
End If
End If

' I should probably extract this to a function.
If TypeName(IDVal) = "String" Then
If oKeyHolder.Exists(IDVal) Then
IDVal = oKeyHolder(IDVal)
Else
Debug.Print "IDVal not set properly. Exiting 'Add_ParseItem'."
Exit Sub
End If
End If

If IsNumeric(EmailVal) And IsNumeric(IDVal) _
And EmailVal < UBound(arr, 2) And IDVal < UBound(arr, 2) Then
For i = LBound(arr) + 1 To UBound(arr)
oFullParser.Add arr(i, EmailVal), arr(i, IDVal)

' Adds the email without the '@email.domain'
oPartParser.Add Left\$(arr(i, EmailVal), InStr(1, arr(i, EmailVal), "@") - 1), _
arr(i, IDVal)
Next

oMainDict.KeyCollection = oKeyHolder

Else
' Error
Debug.Print vbNewLine
Debug.Print "Error when trying to run the 'Add_ParseItem' routine."
Debug.Print "EmailVal is : " & EmailVal
Debug.Print "IDVal is : " & IDVal
Debug.Print "The array is only : " & UBound(arr, 2) & " columns wide."
Debug.Print vbNewLine
End If

Set oFullParser = Nothing
Set oPartParser = Nothing
Set oMainDict = Nothing
Set oKeyHolder = Nothing
Erase arrHolder
End Sub
Public Sub Add_TableItem(arr As Variant, GroupVal As Variant, sKey As String)
Dim i As Long
Dim j As Long

Dim lDepth As Long
Dim lIndex As Long

Dim arrHolder As Variant
Dim arrBuilder As Variant

Dim oKeys As New cSearchableDataset
Dim oMainDict As cSearchableDataset
Dim oSubDict As cSearchableDataset
Dim oSubHolder As cSearchableDataset
Dim oHolder As Object

Set oMainDict = New cSearchableDataset

lDepth = (LBound(GroupVal) - UBound(GroupVal) - 1) * -1

For i = LBound(arr, 2) To UBound(arr, 2)
oKeys.Add arr(LBound(arr, 1), i), i
Next
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
If IsNumeric(GroupVal(LBound(GroupVal))) Then
lIndex = GroupVal(LBound(GroupVal))
Else
lIndex = oKeys.Collector(GroupVal(LBound(GroupVal)))
End If
ReDim arrHolder(LBound(arr, 2) To UBound(arr, 2))
For j = LBound(arr, 2) To UBound(arr, 2)
arrHolder(j) = arr(i, j)
Next
If lDepth = 1 Then
If Not oMainDict.Exists(arr(i, lIndex)) Then
oMainDict.Add arr(i, lIndex), arrHolder
End If
Else
' Create the base entry
ReDim arrBuilder(LBound(GroupVal) To UBound(GroupVal), 1 To 2)
For j = LBound(GroupVal) To UBound(GroupVal)
If TypeName(GroupVal(j)) = "String" Then
lIndex = oKeys.Collector(GroupVal(j))
Else
If IsNumeric(GroupVal(j)) Then
lIndex = GroupVal(j)
Else
' I still need to add an error handler here.
End If
End If

Set oSubDict = New cSearchableDataset
If j <> UBound(GroupVal) Then
oSubDict.Add arr(i, lIndex), vbNullString
ElseIf j = UBound(GroupVal) Then
oSubDict.Add arr(i, lIndex), arrHolder
End If

arrBuilder(j, 1) = arr(i, lIndex)
Set arrBuilder(j, 2) = oSubDict
Next

For j = UBound(arrBuilder) - 1 To LBound(arrBuilder) Step -1
Set oHolder = arrBuilder(j, 2)
Set oHolder.Collector.Item(arrBuilder(j, 1)) = arrBuilder(j + 1, 2)
Next

If Not oMainDict.Exists(arrBuilder(LBound(arrBuilder), 1)) Then
oMainDict.Add arrBuilder(LBound(arrBuilder), 1), _
oHolder.Collector(arrBuilder(LBound(arrBuilder), 1))
Else
oMainDict.Insert_Item arrBuilder, lDepth
End If
End If
Next

oMainDict.KeyCollection = oKeys

Set oMainDict = Nothing
Set oKeys = Nothing
Set oHolder = Nothing
Set oSubHolder = Nothing
Set oSubDict = Nothing
Erase arrBuilder
End Sub


This would then be called by creating a new instance of the class, and then usually by calling the 'Add_TableItem' routine.

EDIT: As a side note, I am a super noob when it comes to classes. I know the basic ideas about how they work, but when it comes to terms like immutable, or encapsulation, etc I have no clue what I am doing. I have been working on improving my class knowledge, but putting it into practice is the more difficult part.

EDIT: Very simple example of the kind of data that would be loaded in and used (the tables usually are about 100-200 columns with 30k-60k rows):

Initial table that is being joined to

ID        Name
1002345   John Doe
1002346   Jane Smith
1002347   Harold Nonsense

Detail Table 1

ID        Score
1002346   100
1002345   95

Detail Table 2

ID        Score
1002345   50
1002347   45
1002346   80

Output

ID        Score_1    Score_2
1002345   95         50
1002346   100        80
1002347              45


Again, this is a very simplified version. Usually I am extracting more data than just a few simple scores. The worst I've had was Day-Over-Day tracking of roughly 40 students on an assignment level basis. This is what led to the need for a dictionary over an array.

• "taking multiple tables (generally formatted in the same way) and joining together these tables based on specific users" --- have you heard of power query and/or SQL? Show an example of your data set and what you end up getting out of it. – Cody Ｇ Mar 22 '17 at 18:39
• I have used power query, but the macros I write are generally for someone else to pull ad-hoc data. I have no current familiarity with SQL, but my team is planning on moving away from VBA and towards SQL within the next few months. – Brandon Barney Mar 22 '17 at 18:58
• Ill see if I can figure out a way of making a sample dataset. The data I work with is sensitive so I cant share it directly, but I will see if I can figure something out. The best way I can explain it though is that I would load in a key table (my initial population of ID's) and then get specific information from columns in other tables that relate to that specific ID. – Brandon Barney Mar 22 '17 at 19:03
• Yeah, you don't need to share the data directly, just the columns (generically) and a few rows of data. – Cody Ｇ Mar 22 '17 at 19:24
• Sorry I can't be of more help, but I definitely think going towards a good database structure in this case will take you places! – Cody Ｇ Mar 22 '17 at 20:00

Naming

You should avoid underscores in member names, i.e. Switch_CompareMode. This isn't a stylistic thing - the underscore has special meaning to the VBA compiler. Note how all of the events (Class_Initialize for example) follow an Interface_Procedure pattern? There's a reason for that, and it's baked into the language. If you get into the habit of using underscores in procedure names now, you'll find it much more difficult to manage when you start writing and implementing your own interfaces and raising your own events. Use PascalCase like everything else: SwitchCompareMode.

I'll throw out my personal distaste for Hungarian notation while I'm at it. The prefix o in particular is meaningless if I can see that it's declared as an object instance and it has an otherwise meaningful name. If you haven't already read it, I'd highly recommend reading Making Wrong Code Look Wrong by Joel Spolsky.

Setting objects to Nothing

You almost never need to do this - the VBA run-time is a self-cleaning organ. If you haven't read the blog post When Are You Required To Set Objects To Nothing? by Eric Lippert (which is much better written and explained than I could do in the space here), do so. When variables go out of scope, they get released. If you do find yourself in a situation where you need to explicitly set an object to Nothing it indicates a design problem - you should probably be using a structure where the life-time of an object is tied to a specific procedure instead. Same thing goes with arrays. You gain absolutely nothing by freeing their memory immediately before they go out of scope, because when they go out of scope...their memory gets cleared. These practices do nothing other than add noise, and usually wind up with me having to quickly check and make sure my scope assumptions were correct by going and finding the declaration. Which leads me to...

Dim blocks

Some people swear by them (some literally), but the last thing that I want to do when I'm reading code is scroll the code pane up to the top of a procedure to find the declaration. If you have any sort of non-trivial procedure, I find it much more readable to have the declaration immediately before the first use (that way I can see WTH the o at the start of it means too).

Vertical White-space

Use it. It helps to make it easier to pick out individual procedures in your code. Not everyone is going to be reading it in the VBE (i.e. me, right now), so it won't always have the VBE rendered line between procedures or the procedure selectors at the top. Write code that is readable on its own, not just readable in one specific tool - people regularly read VBA in notepad, on github, etc. I'd put one blank line between each procedure.

Binding

There is absolutely no reason to late bind to the Microsoft Scripting Runtime - it hasn't changed its interfaces in some developers' lifetimes. You're taking a pretty decent performance hit by late binding because all of the calls have to be dispatched at run-time instead of resolved at compile time. There roughly exactly a 0% chance that an early bound Scripting.Dictionary is going to create any problems with deployment.

Variant Use

This is a data type that invariably leads to problems down the road. In generally, you should type everything as strongly as you can. You're basically giving the compiler and run-time license to treat whatever the variable is as loosely typed, which can lead to unintuitive behavior or bugs. This declaration in particular is a head-scratcher:

Private pKeyCollection As Variant
'...
Public Property Let KeyCollection(value As Object)
Set pKeyCollection = value
End Property

Public Property Get KeyCollection() As Object
Set KeyCollection = pKeyCollection
End Property


That is just all kinds of wrong (and it would look even more wrong if you explicitly declared the return type as the Variant that it is). First, your backing field type doesn't match the publicly declared type. Second, you're using a Property Let as if it was a Property Set. And third, there is no reason for the backing field to be a Variant. The only place where it is used is in the property, so that means you're continually coercing it back and forth, but never use it as a Variant. It also leads to code like this...

oMainDict.KeyCollection = oKeyHolder


...that (to paraphrase Joel Spolsky) makes merely misguided code look wrong. When I see the above line of code, the first thing that pops into my head is "that requires a Set". Going back to the Hungarian notation briefly, your "object prefix" doesn't match the semantics of the assignment, and your property declarations make it possible to ignore the standard reference assignment semantics. It would be difficult to make that line of code look more misleading.

Be Explicit

I'm not just referring to Option Explicit - I mean be explicit with everything you can. For example, this line of code...

Public Sub Insert_Item(arr As Variant, lDepth As Long, Optional lLevel = 0)


...has lLevel implicitly Variant (again, the Hungarian notation lulls you into missing the fact that just because the identifier starts with l, it's not a Long).

Reusing Parameters

Unless you're passing a parameter ByRef and explicitly intend to use it to pass a value between two procedures, you shouldn't be assigning to your parameters. This is 2017, and memory is cheap and plentiful. When VBA was launched, I could have fit the RAM on my PC into the L2 cache of my current processor several times. Spending the extra 4 bytes to declare a local variable isn't going to break the bank. No need to try and fit your stack into the register space of one of the 4 cores on my PC... </rant>

In all seriousness, it makes it harder to determine the intent of the code. When I see a parameter being assigned to, it looks like the intent is to assign back to the caller ByRef. I shouldn't have to constantly check my assumption by trying to find the parameter declaration (see Dim blocks) and checking to see if it's declared ByVal.

Default Instancing

Don't do this unless you have a really good reason to, and I don't mean "not typing a separate assignment" by "good reason":

Dim oFullParser As New cSearchableDataset


The reason is that it completely bypasses all of the few legitimate reasons to Set oFullParser = Nothing (see Setting objects to Nothing) because it allows VBA to auto-instantiate one for you:

Public Sub Example()
Dim foo As New Scripting.Dictionary
Debug.Print foo.Count
Set foo = Nothing
Debug.Print foo.Count   '<-- it's baaaaack...
End Sub


Don't do this. It not only makes your code hard to read and understand, it also makes it really easy to do something unintentional. In this bit of code it's obvious that ComparisonType is an enum (other than the fact you declare the variable as with your Long prefix and the CompareMode member of pCollector returns who knows what because it's declared as Object - looking at you, Hungarian notation...):

lHolder = pCollector.CompareMode
If lHolder = Text Then
lHolder = Binary
Else
lHolder = Text
End If


If that's your Enum, change it. Text and Binary are both VBA keywords. If it isn't your Enum, fully qualify the members both to make it easier for the reader to see what you mean and to avoid any potential that they would inadvertently conflict with the keywords:

If lHolder = ComparisonType.Text Then
lHolder = ComparisonType.Binary
Else
lHolder = ComparisonType.Text
End If


Miscellania

Remove your dead and unused variables vKey in List_Collection, i in Insert_Item and arrHolder in Add_ParseItem (which you inexplicably Erase after never using - see Setting objects to Nothing) jump out, but there might be others.

As far as the design and function, I'll let others tackle that - but I will mention that if you're doing anything that I mentioned above to make the class more "generally usable" it's a code smell. For example, if you use Variant and Object all over the place to make it "generic", you should really be looking at compositing and using interfaces instead. The performance penalties and potential for trading compile-time errors for run-time errors just isn't worth the hassle of having to debug and maintain it.