Convert 2 collections to a dictionary-CodePudding

I have one collection called "rembs". Another called "cols", and an empty dictionary called "pairs". I'd like to pass rembs as the keys of the dictionary and cols as the items. I used a loop to set the keys but I don't know about setting the items. Any ideas how ?

For i = 1 To rembs.Count
    pairs.Add key:=rembs(i), item:=""
Next i

CodePudding user response：

Loop Through Collections and Dictionaries

Option Explicit

Sub CollsToDict()
    
    Const nCount As Long = 10
    
    ' Populate the collections.
    
    Dim rembs As Collection: Set rembs = New Collection
    Dim cols As Collection: Set cols = New Collection
    
    Dim n As Long
    
    For n = 1 To nCount
        rembs.Add n
        cols.Add n   10
    Next n
    
    ' Populate the dictionary.
    
    ' Late Binding
    Dim pairs As Object: Set pairs = CreateObject("Scripting.Dictionary")
    ' Early Binding (requires a reference to 'Microsoft Scripting Runtime').
    'Dim pairs As Scripting.Dictionary: Set pairs = New Scripting.Dictionary
    pairs.CompareMode = vbTextCompare ' case-insensitive
    
    For n = 1 To nCount
        pairs(rembs(n)) = cols(n)
        ' or:
        'pairs.Add rembs(n), cols(n)
        ' or:
        'pairs.Add Key:=rembs(n), Item:=cols(n)
    Next n
    
    ' Print the contents to the Immediate window ('Ctrl G').
    
    Debug.Print "pKey", "pItem", "rembs", "cols"
    
    n = 0

    Dim pKey As Variant

    For Each pKey In pairs.Keys
        n = n   1
        Debug.Print pKey, pairs(pKey), rembs(n), cols(n)
    Next
    
'    ' Only with early binding, you could just do:
'    For n = 1 To nCount
'        Debug.Print pairs.Keys(n - 1), pairs.Items(n - 1), rembs(n), cols(n)
'    Next n
    ' Note that the dictionary is zero-based while the collection is one-based.

End Sub

Results in the Immediate window (Ctrl G)

pKey          pItem         rembs         cols
 1             11            1             11 
 2             12            2             12 
 3             13            3             13 
 4             14            4             14 
 5             15            5             15 
 6             16            6             16 
 7             17            7             17 
 8             18            8             18 
 9             19            9             19 
 10            20            10            20

CodePudding user response：

Inserting two collections (or any combination of an array or collection) into a dictionary is essentially boilerplate code. The best way to deal with boilerplate code is to put it in the object so that scripting dictionary would end up with a Method called 'AddPairs'.

In VBA you can't do this directly. Instead, you have to use a Wrapper, which is a term used for putting an object inside another object and using pass through methods to use the inner object. The class below 'wDictionary', shows how to Wrap the Scripting.Dictionary object to add the functionality you desire, plus an additional method which does what you want in reverse.

The AddPairs Method allows collections or Arrays to be used for the Keys and Items so, assuming you are now using wCollection you can write

   pairs.AddPairs rembs, cols

The wDictionary also has a 'Pairs' method. The pairs method returns an array in the same way as the 'Items' and 'Keys' methods, but, each Item is an array of three Items, the Index, Key and Item. If you've been programming for a while, you'll understand the utility of the Pairs method.

Save the code below as a .cls file and then import it into your project. Replace references to Scripting.Dictionary with wDictionary (or New wDictionary if you are using CreateObject)

The code below is provided as an example. I haven't run any tests but I have done Rubberduck code inspections to ensure that there are no obvious errors.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "wDictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Type State

    Host                    As Scripting.Dictionary
    
End Type

Private s                   As State

Private Sub Class_Initialize()
    Set s.Host = New Scripting.Dictionary
End Sub

Public Sub Add(ByRef Key As Variant, ByRef Item As Variant)
    s.Host.Add Key, Item
End Sub

' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
    
   
    Dim myItemsIndex As Long
    Dim myLastItemsIndex As Long
    If TypeName(Items) = "Collection" Then
    
        myItemsIndex = 1
        myLastItemsIndex = Items.Count
        
    Else
    
        myItemsIndex = LBound(Items)
        myLastItemsIndex = UBound(Items)

    End If
    
    Dim myKey As Variant
    For Each myKey In Keys
    
        If myItemsIndex > myLastItemsIndex Then
        
            Exit For
            
        Else
        
             s.Host.Add myKey, Items(myItemsIndex)
             myItemsIndex = myItemsIndex   1
             
        End If
        
    Next
    
End Sub

Public Property Get CompareMode() As VbCompareMethod
    CompareMode = s.Host.CompareMode
End Property

Public Property Let CompareMode(ByVal RHS As VbCompareMethod)
    s.Host.CompareMode = RHS
End Property

Public Property Get Count() As Long
    Count = s.Host.Count
End Property

Public Function Exists(ByRef Key As Variant) As Boolean
    Exists = s.Host.Exists(Key)
End Function


'@DefaultMember
Public Property Get Item(ByRef Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
    If VBA.IsObject(s.Host(Key)) Then
        Set Item = s.Host(Key)
    Else
        Item = s.Host(Key)
    End If
End Property

Public Property Let Item(ByRef Key As Variant, ByVal RHS As Variant)
    s.Host(Key) = RHS
End Property

Public Property Set Item(ByRef Key As Variant, ByVal RHS As Variant)
    Set s.Host(Key) = RHS
End Property

Public Function Items() As Variant
    Items = s.Host.Items
End Function

Public Function Keys() As Variant
    Keys = s.Host.Keys
End Function

' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
Public Function Pairs() As Variant

    Dim myPairs As Variant
    ReDim myPairs(0 To s.Host.Count - 1)
    Dim myIndex As Long
    myIndex = 0
    Dim myKey As Variant
    For Each myKey In s.Host
        myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
        myIndex = myIndex   1
    Next
    Pairs = myPairs
End Function

Public Property Let Key(ByRef Key As Variant, ByVal NewKey As Variant)
    s.Host.Key(Key) = NewKey
End Property

Public Sub Remove(ByRef Key As Variant)
    s.Host.Remove Key
End Sub


Public Sub RemoveAll()
    s.Host.RemoveAll
End Sub

Update

Of course, the above is quite tedious to write, even though you only have to do the base wrapping once. This is where twinBasic (the up and coming replacement for VB/VBA) has a definite edge. In twin basic the whole code presented above can be condensed to

Class wDictionary

    Implements Scripting.dictionary Via Host = New scripting.dictionary


    ' An enhancement For Each myItem in myDictionary.Pairs return an array containing an index, key and value (items 0,1,2 respectively)
    Public Function Pairs() As Variant

        Dim myPairs As Variant
        ReDim myPairs(0 To s.Host.Count - 1)
        Dim myIndex As Long = 0

        Dim myKey As Variant
        For Each myKey In Host
            myPairs(myIndex) = Array(myIndex, myKey, s.Host(myKey))
            myIndex  = 1
        Next

        Return myPairs
        
    End Function


    ' An Enhancement - The Keys and Items variants must support For each and (Index) or defaultmemeber .Item(Index)
    Public Sub AddPairs(ByVal Keys As Variant, ByRef Items As Variant)
        
    
        Dim myItemsIndex As Long
        Dim myLastItemsIndex As Long
        If TypeName(Items) = "Collection" Then
        
            myItemsIndex = 1
            myLastItemsIndex = Items.Count
            
        Else
        
            myItemsIndex = LBound(Items)
            myLastItemsIndex = UBound(Items)

        End If
        
        Dim myKey As Variant
        For Each myKey In Keys
        
            If myItemsIndex > myLastItemsIndex Then
            
                Exit For
                
            Else
            
                Host.Add myKey, Items(myItemsIndex)
                myItemsIndex  = 1
                
            End If
            
        Next
        
    End Sub

End Class

What's more, twinBasic makes it absolutely trivial to convert wCollection to an activeX.dll so that you can just add a reference to wCollection just as you do for Scripting.Dictionary etc.