Let's say I have two columns in an excel sheet. Column A's is an list of account numbers(integers). Column B consist of the name to the department that account number(Column A) is a assigned to.

My intent is to create a collection for each department. Also each account number(Column A) should be added as an element to it's assigned department's collection.

My approach has been to try a for each loop to create an collection for each department(Column B). Problem is, the sheet I'm working with has 383 account numbers and there are only 11 different departments, so my method produces a lot of duplicate collections instead of adding the account number to the already existing collection.

Please advise a solution or a better way to approach task.

CodePudding user response：

Dictionary vs Collection

Useful Links

• Excel VBA Dictionary – A Complete Guide
• The Ultimate Guide To Collections in Excel VBA

Why the Dictionary?

• You cannot list the keys in a collection while you can in a dictionary:

  For Each Key In dict.Keys
      Debug.Print Key
  Next Key
  

• You need a solution (function) that uses error handling to check if a key exists in a collection while in a dictionary you just do:

  If dict.Exists(Key) Then
  

• You need to create a new object to add it to a collection while in a dictionary you can e.g., to add a new collection, just do:

  Set dict(Key) = New Collection
  

• Unrelated to this case yet very important, e.g. when using a number (simple data type) as the item, you cannot modify its value in a collection while in a dictionary you can e.g. just do:

  dict(Key) = 25 ' modify
  dict(Key) = dict(Key)   1 ' add 1 to count
  dict(Key) = dict(Key)   25 ' add a value to sum
  

A Dictionary of Collections Solution

Option Explicit

Sub Dict2ColumnCollsTEST()
' Need the 'Dict2ColumnColls' functions.
    
    Const KeyColumn As Long = 2
    Const ItemColumn As Long = 1
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    
    Dim rg As Range
    Dim rCount As Long
    
    ' Create a reference to the (relevant) range.
    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count
        If rCount = 1 Then Exit Sub ' nothing or only headers
        rCount = rCount - 1
        Set rg = .Resize(rCount, Application.Max(KeyColumn, ItemColumn)) _
            .Offset(1)
    End With
    
    ' Write the data from the range to an array.
    Dim Data As Variant: Data = rg.Value
    
    ' Write the data from the array to a dictionary (by calling the function).
    Dim dict As Object
    Set dict = Dict2ColumnColls(Data, KeyColumn, ItemColumn)
    If dict Is Nothing Then Exit Sub ' error in the function (Immediate window)
    
    ' Usage (Study) Examples
    
    Dim Key As Variant
    Dim SubItem As Variant
    
    Debug.Print "Print the Keys, Their Count, the Collection (Sub)Items " _
        & "and All of Their Typenames"
    For Each Key In dict.Keys
        Debug.Print "Key = " & Key, "Items.Count = " & dict(Key).Count, _
            TypeName(dict(Key))
        For Each SubItem In dict(Key)
           Debug.Print SubItem, TypeName(SubItem)
        Next SubItem
    Next Key
    
    Debug.Print "Access (Sub)Items by Using the Key"
    Debug.Print "dict(""Executive"")(1) = " & dict("Executive")(1)
    Debug.Print "dict(""AP"")(1) = " & dict("AP")(1)
    Debug.Print "dict(""AP"")(2) = " & dict("AP")(2)
    
    Debug.Print "Loop Through an Item ('Sub-Collection') Using the Key"
    Debug.Print "(For Each SubItem In coll(""AP"")...)"
    For Each SubItem In dict("AP")
        Debug.Print SubItem
    Next SubItem

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a dictionary of collections from the values
'               of two columns of a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Dict2ColumnColls( _
    ByVal Data As Variant, _
    ByVal KeyColumn As Long, _
    ByVal ItemColumn As Long) _
As Object
' Needs the 'DoesCollectionKeyExist' function.
    Const ProcName As String = "Dict2ColumnColls"
    'On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long
    Dim sKey As String
    
    For r = 1 To UBound(Data, 1)
        sKey = CStr(Data(r, KeyColumn))
        If Len(sKey) > 0 Then ' array element is not empty
            If Not dict.Exists(sKey) Then ' key doesn't exist
                Set dict(sKey) = New Collection
            'Else ' key exists
            End If
            dict(sKey).Add Data(r, ItemColumn)
        'Else ' array element is empty
        End If
    Next r

    Set Dict2ColumnColls = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

A Collection of Collections Solution

Sub Coll2ColumnCollsTEST()
' Need the 'Coll2ColumnColls' and 'DoesCollectionKeyExist' functions.
    
    Const KeyColumn As Long = 2
    Const ItemColumn As Long = 1
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    
    Dim rg As Range
    Dim rCount As Long
    
    ' Create a reference to the (relevant) range.
    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count
        If rCount = 1 Then Exit Sub ' nothing or only headers
        rCount = rCount - 1
        Set rg = .Resize(rCount, Application.Max(KeyColumn, ItemColumn)) _
            .Offset(1)
    End With
    
    ' Write the data from the range to an array.
    Dim Data As Variant: Data = rg.Value
    
    ' Write the data from the array to a collection (by calling the function).
    Dim coll As Collection
    Set coll = Coll2ColumnColls(Data, KeyColumn, ItemColumn)
    If coll Is Nothing Then Exit Sub ' error in the function (Immediate window)
    
    ' Usage (Study) Examples
    
    Dim Item As Variant
    Dim SubItem As Variant
    
    Debug.Print "Print the Sub-Items, All Counts and All Typenames" & vbLf _
        & "(no way to list the keys (""Item.Count""))"
    For Each Item In coll
        Debug.Print "Item.Count=" & Item.Count, TypeName(Item)
        For Each SubItem In Item
           Debug.Print SubItem, TypeName(SubItem)
        Next SubItem
    Next Item
    
    Debug.Print "Access the Sub-Items by Using the Key"
    Debug.Print "coll(""Executive"")(1) = " & coll("Executive")(1)
    Debug.Print "coll(""AP"")(1) = " & coll("AP")(1)
    Debug.Print "coll(""AP"")(2) = " & coll("AP")(2)
    
    If DoesCollectionKeyExist(coll, "AP") Then
        Debug.Print "Loop Through an Item ('Sub-Collection') Using the Key"
        Debug.Print "(For Each SubItem In coll(""AP"")...)"
        For Each SubItem In coll("AP")
            Debug.Print SubItem
        Next SubItem
    End If

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a collection of collections from the values
'               of two columns of a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Coll2ColumnColls( _
    ByVal Data As Variant, _
    ByVal KeyColumn As Long, _
    ByVal ItemColumn As Long) _
As Collection
' Needs the 'DoesCollectionKeyExist' function.
    Const ProcName As String = "Coll2ColumnColls"
    On Error GoTo ClearError
    
    Dim coll As Collection: Set coll = New Collection
    
    Dim subcoll As Collection
    Dim r As Long
    Dim sKey As String
    
    For r = 1 To UBound(Data, 1)
        sKey = CStr(Data(r, KeyColumn))
        If Len(sKey) > 0 Then ' array element is not empty
            If Not DoesCollectionKeyExist(coll, sKey) Then ' key doesn't exist
                Set subcoll = New Collection
                coll.Add subcoll, sKey
            'Else ' key exists
            End If
            coll(sKey).Add Data(r, ItemColumn)
        'Else ' array element is empty
        End If
    Next r

    Set Coll2ColumnColls = coll

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a boolean indicating whether a key of a collection
'               exists.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DoesCollectionKeyExist( _
    ByVal coll As Collection, _
    ByVal Key As String) _
As Boolean
    On Error GoTo ClearError
    IsObject (coll(Key))
    DoesCollectionKeyExist = True
ProcExit:
    Exit Function
ClearError:
    Resume ProcExit
End Function