2
\$\begingroup\$

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
        pCollector.Add sKey, oItem
    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.Add "Full", oFullParser
        oMainDict.Add "Partial", oPartParser
        oMainDict.KeyCollection = oKeyHolder

        pCollector.Add sKey, oMainDict
    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
    pCollector.Add sKey, oMainDict

    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.

\$\endgroup\$
  • \$\begingroup\$ "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. \$\endgroup\$ – Cody G Mar 22 '17 at 18:39
  • \$\begingroup\$ 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. \$\endgroup\$ – Brandon Barney Mar 22 '17 at 18:58
  • \$\begingroup\$ 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. \$\endgroup\$ – Brandon Barney Mar 22 '17 at 19:03
  • \$\begingroup\$ Yeah, you don't need to share the data directly, just the columns (generically) and a few rows of data. \$\endgroup\$ – Cody G Mar 22 '17 at 19:24
  • 1
    \$\begingroup\$ 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! \$\endgroup\$ – Cody G Mar 22 '17 at 20:00
4
\$\begingroup\$

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
    foo.Add "bar", vbNull
    Debug.Print foo.Count
    Set foo = Nothing
    Debug.Print foo.Count   '<-- it's baaaaack...
End Sub

Overloading VBA Keywords

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.

\$\endgroup\$
  • \$\begingroup\$ @Computers Thank you very much for your time in reviewing this. When I read through it, your comments made perfect sense. I haven't had a chance to implement it yet (been a busy couple of days) but I didn't want you to think I hadn't seen your answer :). I'll definitely be going over your feedback soon, and I'll be sure to ask any questions that come up. \$\endgroup\$ – Brandon Barney Mar 24 '17 at 10:47
  • \$\begingroup\$ @Comimterm I apologize for getting back to this so late. Posting this right before moving (and a week out of the office) was a poor call on my part. I can definitely see now how Hungarian Notation (System), is a poor choice. I initially saw it in someone else's post on SO and thought it made sense. I didn't think of the consequences it could bring. Likewise, I was pretty sure that Objects would release as soon as they went out of scope, but there was some uncertainty in the community (likely programmers as inexperienced as myself) so I went with the safe-not-sorry approach. \$\endgroup\$ – Brandon Barney Apr 3 '17 at 12:41
  • \$\begingroup\$ The variants you noted were leftovers from debugging that I hadn't caught. The only time I intend to use variants is with arrays. I will be sure to hunt those down. On binding, from your post it sounds like it is safe to early bind with dictionaries for deployment. I went with late-binding because I dont want to add references on everyone else's machine, so I will test early-binding out to make sure it doesn't present this issue. Can you point me in the right direction of knowing when early-binding is safe for deployment? I read somewhere that late-binding was the only way of being certain. \$\endgroup\$ – Brandon Barney Apr 3 '17 at 12:44
  • \$\begingroup\$ Lastly, what do you mean when you say compositing and using interfaces? This certainly may be something I need, I just haven't a clue on where to start with using these. Currently, since I am the only one writing the projects, I tend to just debug the code myself and, as noted, I only intentionally use variants for arrays. If there is anything that I can learn to make my code more flexible I will gladly hunt it down. Thank you for your extensive feedback! \$\endgroup\$ – Brandon Barney Apr 3 '17 at 12:47

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.