I have a dict made up of multiple items (dates) per key, looks like this

 Key          Items dates()
 23359720     03/12/2020 , 04/12/2020, 05/12/2020 
 23293711     26/01/2021 

How can I transfer each key & item into an array (including repeating keys for multiple items)? so that array:

23359720 03/12/2020
23359720 04/12/2020
...      ....

This is the code I have:

Sub Test_Dates()

'
Dim TESTWB As Workbook
Dim TESTWS As Worksheet

Set TESTWB = ThisWorkbook
Set TESTWS = TESTWB.Worksheets("TEST")

Dim Dict As New Scripting.Dictionary

For i = 2 To TESTWS.Cells(1, 1).End(xlDown).Row
      Dict.Add TESTWS.Cells(i, 1).Value, getDates(TESTWS.Cells(i, 2), TESTWS.Cells(i, 3))
      
Next i

For i = 0 To Dict.Count - 1
    Dim DateItem As Variant
    For Each DateItem In Dict.Items(i)
        Debug.Print Dict.Keys(i), DateItem
    Next DateItem
Next i


'Dict to Array

Dim PricingDatesArr As Variant

PricingDatesArr = Dict.Keys

PricingDatesArr = Dict.Items

End Sub

This is to get dates between 2 sets of dates (i,2) (i,3) in the code

Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant

    Dim varDates()      As Date
    Dim lngDateCounter  As Long

    ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))

    For lngDateCounter = LBound(varDates) To UBound(varDates)
        varDates(lngDateCounter) = CDate(StartDate)
        StartDate = CDate(CDbl(StartDate)   1)
    Next lngDateCounter

    getDates = varDates


End Function

CodePudding user response：

This is the third question you have posted in as many days regarding Dictionaries. You might want to take a little time out a read up on Dictionary data structures a bit more.

The code below will return a 1 to n,by 1 to 2 array from a dictionary with arrays of dates.

Option Explicit

Public Function UnpackDictionaryOfArrays(ByRef ipDict As Scripting.DIctionary) As Variant

Dim myKeys As Collection
Set myKeys = New Collection

Dim myItems As Collection
Set myItems = New Collection


    Dim myKey As Variant
    Dim myItem As Variant
    
    For Each myKey In ipDict
    
        myItem = ipDict(myKey)
        If IsArray(myItem) Then
        
            Dim myElement As Variant
            For Each myElement In myItems
            
                myKeys.Add myKey
                myItems.Add myElement
                
            Next
            
        Else
        
            myKeys.Add myKey
            myItems.Add myItem
            
        End If
        
    Next
    
    ' Now compile into a single array
    Dim myKeyItem As Variant
    ReDim myKeyItem(1 To myKeys.Count, 1 To 2)
    
    Dim myIndex As Long
    For myIndex = 1 To myKeys.Count
    
        myKeyItem(myIndex, 1) = myKeys(myIndex)
        myKeyItem(myIndex, 2) = myItems(myIndex)
        
    Next
    
    UnpackDictionaryOfArrays = myKeyIndex
    
End Function

CodePudding user response：

Dictionary With Arrays to 2D One-Based Array

' Dict to Array

' Count the number of dates.
Dim Arr As Variant
Dim pCount As Long
For Each Arr In Dict.Items
    pCount = pCount   UBound(Arr) - LBound(Arr)   1
Next Arr

' Resize the array to the number of dates.
Dim PricingDatesArr As Variant: ReDim PricingDatesArr(1 To pCount, 1 To 2)

' Write the data to the array.
Dim Key As Variant
Dim n As Long, r As Long
For Each Key In Dict.Keys
    For n = LBound(Dict(Key)) To UBound(Dict(Key))
        r = r   1
        PricingDatesArr(r, 1) = Key
        PricingDatesArr(r, 2) = Dict(Key)(n)
    Next n
Next Key

' Print the elements of the array.
For r = 1 To pCount
    Debug.Print PricingDatesArr(r, 1), PricingDatesArr(r, 2)
Next r

' Copy to a range.
'SheetX.Range("A1").Resize(pCount, 2).Value = PricingDatesArr

EDIT: The Function Edition

Usage in Your Code

' Dict to Array
Dim PricingDatesArr As Variant
PricingDatesArr = UnpivotDictionaryArrays(dict)
If IsEmpty(PricingDatesArr) Then Exit Sub  

' Print the elements of the array.
For r = 1 To pCount
    Debug.Print PricingDatesArr(r, 1), PricingDatesArr(r, 2)
Next r

' Copy to a range.
'SheetX.Range("A1").Resize(pCount, 2).Value = PricingDatesArr

The Function

Function UnpivotDictionaryArrays( _
    ByVal dict As Object) _
As Variant
    Const ProcName As String = "UnpivotDictionaryArrays"
    On Error GoTo ClearError

    ' Count the items of the source (dictionary) arrays.
    Dim Item As Variant
    Dim n As Long
    For Each Item In dict.Items
        n = n   UBound(Item) - LBound(Item)   1
    Next Item
    
    ' Write the values from the dictionary to the destination array.
    Dim Data As Variant: ReDim Data(1 To n, 1 To 2)
    Dim r As Long
    For Each Item In dict.Keys
        For n = LBound(dict(Item)) To UBound(dict(Item))
            r = r   1: Data(r, 1) = Item: Data(r, 2) = dict(Item)(n)
        Next n
    Next Item

    UnpivotDictionaryArrays = Data

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