Add items as collection to dictionary

[jaryszek]

Hi Guys,

I have a code:

Sub test()

Dim dict As Object
Dim coll As Collection
Dim key As Variant


Set dict = CreateObject("Scripting.Dictionary")
Set coll = New Collection
coll.Add ("coll1")
coll.Add ("coll2")
coll.Add ("coll3")
If Not dict.Exists("dict1") Then
    dict.Add "dict1", coll
End If


Dim vitems, vkeys As Variant


vitems = dict.keys
vkeys = dict.Items


For Each key In dict
    Debug.Print dict.Items(key)
Next key


Set dict = Nothing


End Sub

i would like to access this 3 items and transpose them to another sheet.

Example:

I have a list with People. For this people (keys) they are assigned values: value1, value2 and value 3 from different columns.

So i want to have the list of people with assigned to them all items as result:

Man1, value1, value2, value3.

So my idea is to use collections (checking if Man is existing twice) and after that transpose whole dictionary to another sheet.

Please help me with code to get values from dictionary.
This is difficult for me.

Best wishes
Jacek Antek

 

[Domenic]

This macro assumes the following...

1) The sheet containing the data is the active sheet.

2) Column A contains the name, and Columns B, C, and D contain the corresponding data.

3) Row 1 contains the column headers, and the data starts at Row 2.
​

Note that the macro uses the Dictionary object to keep track of existing names. If a name doesn't already exist, the name and corresponding data are stored in an array. Then, the contents of the array are transferred to the same worksheet, starting at F2.

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] ListUniqueData()

    [COLOR=darkblue]Dim[/COLOR] oDic [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] aResult() [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] sName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ArrayIndex [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] RowIndex [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] LastRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] oDic = CreateObject("Scripting.Dictionary")
    oDic.CompareMode = 1 [COLOR=green]'vbTextCompare[/COLOR]
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    [COLOR=darkblue]ReDim[/COLOR] aResult(1 [COLOR=darkblue]To[/COLOR] 4, 1 [COLOR=darkblue]To[/COLOR] LastRow)
    
    ArrayIndex = 0
    [COLOR=darkblue]For[/COLOR] RowIndex = 2 [COLOR=darkblue]To[/COLOR] LastRow
        sName = Cells(RowIndex, "A").Value
        [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] oDic.Exists(sName) [COLOR=darkblue]Then[/COLOR]
            ArrayIndex = ArrayIndex + 1
            aResult(1, ArrayIndex) = sName
            aResult(2, ArrayIndex) = Cells(RowIndex, "B").Value
            aResult(3, ArrayIndex) = Cells(RowIndex, "C").Value
            aResult(4, ArrayIndex) = Cells(RowIndex, "D").Value
            oDic.Add sName, ""
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] RowIndex
    
    [COLOR=darkblue]ReDim[/COLOR] [COLOR=darkblue]Preserve[/COLOR] aResult(1 To 4, 1 To ArrayIndex)
    
    Range("F2").Resize(UBound(aResult, 2), UBound(aResult, 1)).Value = Application.Transpose(aResult)
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!

 

[jaryszek]

Hi Domenic,

thank you for your post.
Your solution is interesting.

Problem is more complex.
I have a data like this:

Person	Value	Value2	Value3
1.PersonA	Value1	Value1a	500
2.PersonB	Value2	Value2a	300
3.PersonA	Value1	Value1a	100

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

And dictionary should check if specific key is exists and:

1. If not --> add collection without any changes to this dictionary. (Row number 1) --> Key: PersonA, items : Value1, Value1a, 500
2. If yes --> Row number 3. Key: PersonA and for collection item = 500 add 100 --> result, Key: PersonA, items: Value1, Value1a, 600

And with row numer 3 : Dictionary, key: Person B, items: Value2, Value2a, 300.

So in this solution is lack of summing.
How can we solve that?

Jacek

 

[jaryszek]

Ok i have found the one solution but i do not know if this solution is good:

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">objDictionary.item(dicKey) = dicVal3 & ", " & dicVal & ", " & dicVal2</code>

I can join items in collection like in this code.
But if it the fastest way in order to solve this ?

Best Regards,
Jacek Antek

 

[jaryszek]

Update:

my code is looking right now like this :

Sub WorkBooks_Looping()

    Dim wbMain As Workbook
    Dim wsCount As Integer
    Set wbMain = ThisWorkbook
    Dim i As Long
    Dim y As Long
    Dim ArrayLoop As Variant
    Dim Dict_People As Object
    Dim coll As New Collection
    Dim wbworkbook As Worksheet
    
'''    wsCount = wbworkbook.Worksheets.Count
    
    Set wbworkbook = ActiveSheet
    
'''    For i = 1 To wsCount
'''        If wbworkbook.Worksheets(i).Name Like "20*" Then
            Set Dict_People = CreateObject("Scripting.dictionary")
            ArrayLoop = wbworkbook.Range(Cells(2, 5), Cells(154, 10))
            
            For y = 1 To UBound(ArrayLoop)
    y = 14
                
    If Not Dict_People.Exists(ArrayLoop(y, 3)) Then
    
        coll.Add ArrayLoop(y, 3)
        coll.Add ArrayLoop(y, 1)
        coll.Add ArrayLoop(y, 2)
        coll.Add ArrayLoop(y, 6)
        Dict_People.Add ArrayLoop(y, 3), coll
        Set coll = New Collection
        
Dim vitems, vkeys As Variant


vkeys = Dict_People.Keys
vitems = Dict_People.Items


Debug.Print Dict_People.Item(ArrayLoop(y, 3))(1)

Question about this "debug.Print Dict_People.Item(ArrayLoop(y, 3))(1)"

this is working. Result will be: "Galemba"

https://s29.postimg.org/4wfav2gcn/Bez_tytu_u.png

I would like to assing value for this key and for this exact item like this:

Dict_People.Item(ArrayLoop(y, 3))(1) = 1 but error is occuring...

Please help Guys,
Jacek

 

[Domenic]

Hi Domenic,

thank you for your post.
Your solution is interesting.

Problem is more complex.
I have a data like this:

Person	Value	Value2	Value3
1.PersonA	Value1	Value1a	500
2.PersonB	Value2	Value2a	300
3.PersonA	Value1	Value1a	100

<tbody>
</tbody>

And dictionary should check if specific key is exists and:

1. If not --> add collection without any changes to this dictionary. (Row number 1) --> Key: PersonA, items : Value1, Value1a, 500
2. If yes --> Row number 3. Key: PersonA and for collection item = 500 add 100 --> result, Key: PersonA, items: Value1, Value1a, 600

And with row numer 3 : Dictionary, key: Person B, items: Value2, Value2a, 300.

So in this solution is lack of summing.
How can we solve that?

Jacek

In that case, you can simply amend my code as follows...

Option Explicit

Sub ListUniqueData()

    Dim oDic As Object
    Dim aResult() As Variant
    Dim sName As String
    Dim ArrayIndex As Long
    Dim RowIndex As Long
    Dim LastRow As Long
    
    Set oDic = CreateObject("Scripting.Dictionary")
    oDic.CompareMode = 1 'vbTextCompare
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ReDim aResult(1 To 4, 1 To LastRow)
    
    ArrayIndex = 0
    For RowIndex = 2 To LastRow
        sName = Cells(RowIndex, "A").Value
[COLOR=#ff0000]        If Not oDic.Exists(sName) Then
            ArrayIndex = ArrayIndex + 1
            aResult(1, ArrayIndex) = sName
            aResult(2, ArrayIndex) = Cells(RowIndex, "B").Value
            aResult(3, ArrayIndex) = Cells(RowIndex, "C").Value
            aResult(4, ArrayIndex) = Cells(RowIndex, "D").Value
            oDic.Add sName, ArrayIndex
        Else
            aResult(4, oDic.Item(sName)) = aResult(4, oDic.Item(sName)) + Cells(RowIndex, "D").Value
        End If[/COLOR]
    Next RowIndex
    
    ReDim Preserve aResult(1 To 4, 1 To ArrayIndex)
    
    Range("F2").Resize(UBound(aResult, 2), UBound(aResult, 1)).Value = Application.Transpose(aResult)
    
End Sub

Hope this helps!

 

[RoryA]

Jacek,

Please use code tags, not quote tags, when posting code. Thanks.

 

[jaryszek]

Thank you Domenic for you help!

Your code is nice but problem will be when I will be looping through sheets and through workbooks (all time redim array? It will be bad approach).
Additionally I have blanks rows also so I should know how many elements my array will have.

To do this I have to do 2 loops - one which will count elements for second array like in youe example.

This will be not the best solution. Not the fastest.

I think that the best solution will be using a class and pass it into dictionary.

I think that you can not assign exact item to a key:

[COLOR=#333333]Dict_People.Item(ArrayLoop(y, 3))(1) = 1[/COLOR]

You can only read from this...

So if here will be a class element - it will be working fine.

I would like to ask you if somebody do similar with dictionary and classess ?

Best Regards,
Jacek Antek

 

[Domenic]

Thank you Domenic for you help!

You're very welcome!

Your code is nice but problem will be when I will be looping through sheets and through workbooks (all time redim array? It will be bad approach).
Additionally I have blanks rows also so I should know how many elements my array will have.

While I haven't tested it, I don't think it would be terribly inefficient to redim the array variable for each worksheet. The blanks rows wouldn't be an issue since the array will be redimmed according to the number unique entries.

I think that the best solution will be using a class and pass it into dictionary.

Sure, that's likely a more efficient solution...

I think that you can not assign exact item to a key:

[COLOR=#333333]Dict_People.Item(ArrayLoop(y, 3))(1) = 1[/COLOR]

You can only read from this...

In my example, the dictionary is simply used as a lookup table. The name is used to lookup the index that indicates which column within the array contains the data for the specified name.

I would like to ask you if somebody do similar with dictionary and classess ?

Yes, a class is created, data is assigned to objects created for that class, and then those objects are stored in a collection (or dictionary if you prefer). Try searching this board or Google for some examples. Actually, here's a link that should help...

Classes In VBA