PDA

View Full Version : [SOLVED] Store rows in dictionary or collection



YasserKhalil
07-09-2017, 02:51 AM
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
07-09-2017, 03:29 AM
http://www.snb-vba.eu/VBA_Dictionary_en.html

YasserKhalil
07-09-2017, 03:37 AM
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
07-09-2017, 07:11 AM
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
07-09-2017, 09:34 AM
That's amazing Mr. Paul
Thank you very much for great assistance
Best Regards

YasserKhalil
07-09-2017, 02:18 PM
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
07-10-2017, 11:00 AM
Any help in that topic please?

Leith Ross
07-11-2017, 01:35 PM
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
07-11-2017, 11:44 PM
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
07-12-2017, 07:19 AM
Hello Yasser,

You're welcome.