Store rows in dictionary or collection

[YasserKhalil]

Hello everyone
I need to learn how to store a row or multiple rows in dictionary or collection but if possible with comments to get and understand the process
Simple example I have IDs in column A and I need to get the unique ID and store each ID in sub-collection ...
For example : the ID 8 is in three rows 4 - 5 - 8
How to store those three rows in one sub-collection? and so on for the other IDs

And how to put the results in worksheet .. (no matter the output) I just need how to populate the stored rows to the worksheet

[snb]

http://www.snb-vba.eu/VBA_Dictionary_en.html

[YasserKhalil]

Thanks a lot for reply
I have seen that link before and it is very useful but it seems I can't get it as a whole issue
If possible to deal with the attachment and put comments .. I learn by example better
Thanks advanced for help

[Paul_Hossler]

You can play around with this

Option Explicit
Sub Demo()
    Dim oDict As Object
    Dim rData As Range, rTemp As Range
    Dim iRow As Long
    Dim v As Variant
    Dim sKey As String
    
    'create late bound dictionary object
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = vbTextCompare
    
    'the data to add
    Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
    'skip header row
    For iRow = 2 To rData.Rows.Count
        
        'save the key value
        sKey = CStr(rData.Cells(iRow, 1).Value)
        
        'if the key is already in the dictionary, then Union the other row with the same key
        If oDict.exists(sKey) Then
            Set rTemp = oDict(sKey)
            Set rTemp = Union(rTemp, rData.Rows(iRow))
            Set oDict(sKey) = rTemp
        'otherwise just add the key and row
        Else
            oDict.Add sKey, rData.Rows(iRow)
        End If
    
    Next iRow
    
    'loop through the disctionary items
    For Each v In oDict.items
        MsgBox v.Address
    Next v
    Set oDict = Nothing

End Sub

[YasserKhalil]

That's amazing Mr. Paul
Thank you very much for great assistance
Best Regards

[YasserKhalil]

Sorry for disturbing you again Mr. Paul
What if I need to store the values in each row (not to store the rows as ranges as you did)
That's because I intend to deal with closed workbooks to gather data and I need to store the values for each key ...

Thanks advanced for help

[YasserKhalil]

Any help in that topic please?

[Leith Ross]

Hello Yasser,

I have added this macro to the attached workbook. This uses the Dictionary and Variant Arrays to hold the Range data. When possible, it is easier and faster to manipulate arrays than objects.

Here is the macro...

Option Explicit


Sub Macro1()


    Dim Cell    As Range
    Dim Data    As Variant
    Dim Dict    As Object
    Dim Item    As Variant
    Dim Key     As Variant
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    Dim x       As Long
    Dim y       As Long
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set RngBeg = Wks.Range("A2:D2")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
        
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        Set Rng = Wks.Range(RngBeg, RngEnd)
        
        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
            For Each Cell In Rng.Columns(1).Cells
                Key = Trim(Cell)
                Item = Cell.Resize(1, Rng.Columns.Count).Value
                
                If Not Dict.Exists(Key) Then
                    Dict.Add Key, Item
                Else
                    ' To increase the rows in the 2-D array it must first be transposed.
                    ' Only the last dimension of an array can be resized.
                    Data = Application.Transpose(Dict(Key))
                        x = UBound(Data, 1)
                        y = UBound(Data, 2) + 1
                        ReDim Preserve Data(1 To x, 1 To y)
                    ' Transposing the array a second time restores the original order.
                    Data = Application.Transpose(Data)
                    
                    ' Load the new data.
                    For x = 1 To UBound(Item, 2)
                        Data(y, x) = Item(1, x)
                    Next x
                    
                    ' Save the Data.
                    Dict(Key) = Data
                End If
            Next Cell
        
        Set Rng = Wks.Range("G2")
        
        For Each Item In Dict.Items
            x = UBound(Item, 1)
            y = UBound(Item, 2)
            Rng.Resize(x, y).Value = Item
            Set Rng = Rng.Offset(x, 0)
        Next Item
        
End Sub

[YasserKhalil]

That's awesome Mr. Leith
You are wonderful and I like your approach in coding
Thank you very much for both of you for these great solutions

[Leith Ross]

Hello Yasser,

You're welcome.