vba - add collection to Dictionary - dictionnary to worksheet

[Mallesh23]

Hi Team,

I am adding all rows to collection, and from collection adding to Dictionary.
and then from Dictionary to worksheet. I saw one video on youtube Make Your VBA Code Run 1000 Faster Part-2.

its not pasting as expected. Thanks

Input Data:-

Book1
	A	B	C	D	E	F	G	H
1	1270	1159	1919	1374	1426	1033	1043	1462
2	1162	1579	1946	1644	1951	1871	1054	1665
3	1851	1699	1776	1610	1722	1221	1702	1995
4	1552	1591	1047	1008	1338	1197	1745	1802
5	1337	1635	1836	1580	1724	1409	1749	1407
6	1426	1458	1998	1968	1773	1191	1006	1749
7	1838	1860	1446	1340	1744	1988	1862	1034
8	1902	1696	1644	1789	1518	1526	1772	1360
9	1138	1455	1817	1838	1280	1202	1058	1940
10	1777	1127	1231	1897	1430	1956	1653	1324
11	1618	1238	1582	1247	1648	1159	1709	1716
12	1159	1752	1806	1015	1510	1508	1160	1299
13	1074	1537	1772	1347	1380	1434	1411	1707
14	1894	1200	1820	1431	1593	1580	1059	1048
15	1612	1834	1243	1560	1103	1868	1646	1681
16	1606	1146	1088	1823	1221	1567	1350	1932
17	1660	1195	1783	1264	1448	1097	1870	1652
18	1339	1772	1653	1065	1825	1757	1279	1731
19	1219	1556	1223	1047	1502	1377	1053	1839
20	1966	1878	1877	1675	1826	1472	1347	1493
21	1545	1805	1728	1244	1986	1799	1919	1109
Sheet1

[CODE=vba]Option Explicit

Sub ReadRows()

    Dim coll As New Collection, i As Long
    
    'Read Data to Collection - all rows
    Dim rg As Range
    Set rg = Range("A1").CurrentRegion
    
    For i = 1 To rg.Rows.Count
        coll.Add rg.Rows(i)
    Next i
    
    'Add Collection to Dictionary
    ReadCollectionToDictionary coll

End Sub
Private Function ReadCollectionToDictionary(ByVal coll As Collection) As Object

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = 1 To coll.Count
        dict.Add i, coll(i)
    Next i
    
    Set ReadCollectionToDictionary = dict
    WriteDictionaryToWorksheet dict

End Function


Private Sub WriteDictionaryToWorksheet(dict As Object)
    Range("A1").CurrentRegion.ClearContents

    Dim row As Long
    row = 1
        Cells(row, 1).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.keys)
        Cells(row, 2).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.items)
End Sub

[/CODE]

 

[Domenic]

Since you're using late binding, the Items method of the Dictionary object should include empty brackets in order to return the array...

dict.items()

Then, since you've added Range objects to your collection, and utimately to your dictionary, you can return the first range from your dictionary as follows...

dict.items()(0)

Then, to return the array of values from the range object, you'll need to do the following...

dict.items()(0).value

However, the returned array will be empty since you clear the cell contents prior to transferring them to your worksheet. So I would suggest that you don't clear those cells, and simply transfer the values to a separate sheet.

By the way, there's no need to use a collection, since you're already using a dictionary. In fact, since it looks like you don't need to do any sort of lookup, you could dispense with the dictionary as well. You could simply use a two dimensional array to hold your index/range pair, or even an index/array pair.

 

[Mallesh23]

Hi Domenic,

Thanks for your help and also nice explanation on this concept.

In collection we can't use transpose. So thought of taking collection value into dictionary and transpose without looping.

is it possible transpose all rows? in dictionary without looping.
it transpose single Row (dict.items()(0).value) , Also what will be code for early binding

Private Sub WriteDictionaryToWorksheet(dict As Object)
    sht_output.Range("A1").CurrentRegion.ClearContents

    Dim row As Long
    row = 1
        sht_output.Range.Cells(row, 1).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.keys)
        sht_output.Range.Cells(row, 2).Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.items()(0).value)  'Transpose First Row
End Sub

In my actual project I am adding all rows to collection by Avoiding autofilter.as autofilter is slow.
and I am printing collection to output sheet. via loop as below. its working

Sub WriteData(ByVal sh As Worksheet, ByVal StartRow As Long, coll As Collection)

    Dim item As Variant, Row As Long, Columns As Long
    sh.Cells.ClearContents

    Row = StartRow
    For Each item In coll
        Columns = UBound(item, 2)
        sh.Cells(Row, 1).Resize(1, Columns).Value = item
        Row = Row + 1
    Next

End Sub

 

[Domenic]

You've post a sample of your data, so that's great. But can you please post the actual results that you expect? It looks like you want the results as follows...

1​	1270​
1​	1159​
1​	1919​
1​	1374​
1​	1426​
1​	1033​
1​	1043​
1​	1462​
2​	1162​
2​	1579​
2​	1946​
2​	1644​
2​	1951​
2​	1871​
2​	1054​
2​	1665​
3​	1851​
3​	1699​
etc...​	etc...​

Is this correct?

 

[Mallesh23]

Hi Domenic


Through collection if I add 15 rows of data and It contains 8 Columns.
I want 15 Rows data and 8 Columns.

Like Sht_output.range("a1:h1").value = Sht_input.range("a1:h1").value
Sht_output.range("a2:21").value = Sht_input.range("a2:h2").value and so on ...


Add collection Data to Dictionary and print from Dictionary to Worksheet



Thanks
mg

 

[Domenic]

Sorry, but it's unclear to me how you want the resulting data laid out. Can you post the actual resulting data?

 

[Mallesh23]

Hi Dominic,

Column A to E is Actual Data, and want result in Column J onward.
here I have used loops for writing Collection Data to Range. how to achieve same task via Dictionary.
is it possible to avoid loop in dictionary for writing to sheet. using transpose method .

My attmpted working code as follows.

Sub FilterData()
        
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(1)

    
    Dim rg As Range
    Set rg = sh.Range("A1").CurrentRegion
    
    Dim arr_country As Variant
    Dim arr_region As Variant
    
    arr_country = Join(Array("India", "America"), "!")
    arr_region = Join(Array("North", "South"), "!")
    
    Dim i As Long
    '
    'Read Data to Collection
    Dim coll As New Collection
    
    For i = 2 To rg.Rows.Count
        If InStr(1, arr_country, Cells(i, 1), vbTextCompare) > 0 Then
            If InStr(1, arr_region, Cells(i, 2), vbTextCompare) > 0 Then
                If rg.Cells(i, 3).Value > 500 Then
                    coll.Add rg.Rows(i).Value   'add complete Range
                End If
            End If
        End If
    Next i

if coll.count>1 then    
WriteData sh, 2, coll
end if

End Sub

Sub WriteData(ByVal sh As Worksheet, ByVal StartRow As Long, coll As Collection)
    Dim item As Variant, Row As Long, Columns As Long
    Row = StartRow
    For Each item In coll
        Columns = UBound(item, 2)
        sh.Cells(Row, 9).Resize(1, Columns).Value = item
        Row = Row + 1
    Next
End Sub

Actual Data and expected output.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Country	Region	Sales	Product	Bonus				Country	Region	Sales	Product	Bonus
2	Sri Lanka	South	610	xxx	yyy				India	South	800	xxx	yyy
3	India	South	800	xxx	yyy				America	North	780	xxx	yyy
4	Australia	North	720	xxx	yyy				India	North	650	xxx	yyy
5	America	North	780	xxx	yyy				America	South	810	xxx	yyy
6	Germanay	West	860	xxx	yyy
7	FRANCE	EAST	970	xxx	yyy
8	India	North	650	xxx	yyy
9	Pakistan		440	xxx	yyy
10	America	East	500	xxx	yyy
11	Brazil	West	520	xxx	yyy
12	America	South	810	xxx	yyy
13	Brazil	EAST	650	xxx	yyy
14	America	South	400	xxx	yyy
15	Australia	South	720	xxx	yyy
16	India	West	610	xxx	yyy
Sheet1

Thanks
mg

 

[Domenic]

Here's your code, which has been amended so that it uses a Dictionary instead of a Collection. And, it voids looping, and uses Tranpose to write the data to your worksheet.

Sub FilterData()
      
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(1)

  
    Dim rg As Range
    Set rg = sh.Range("A1").CurrentRegion
  
    Dim arr_country As Variant
    Dim arr_region As Variant
  
    arr_country = Join(Array("India", "America"), "!")
    arr_region = Join(Array("North", "South"), "!")
  
    Dim i As Long
    '
    'Read Data to Dictionary
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
  
    For i = 2 To rg.Rows.Count
        If InStr(1, arr_country, Cells(i, 1), vbTextCompare) > 0 Then
            If InStr(1, arr_region, Cells(i, 2), vbTextCompare) > 0 Then
                If rg.Cells(i, 3).Value > 500 Then
                    dic.Add rg.Rows(i).Cells(1, 1).Value & "#" & rg.Rows(i).Cells(1, 2).Value, rg.Rows(i).Cells.Value 'add complete Range
                End If
            End If
        End If
    Next i

If dic.Count > 1 Then
     WriteData sh, 2, dic
End If

End Sub

Sub WriteData(ByVal sh As Worksheet, ByVal StartRow As Long, dic As Object)
  
    Dim temp_array As Variant
  
    temp_array = Application.Transpose(dic.Items())
  
    temp_array = Application.Transpose(temp_array)
  
    sh.Cells(StartRow, 9).Resize(UBound(temp_array, 1), UBound(temp_array, 2)).Value = temp_array
  
End Sub

Here are some notes that I hope will help in understanding what's going on...

dic.Items() returns a zero-based, four-element, one-dimensional array, where each element contains a 1 Row by 5 Column, two-dimensional array.

dic.items()(0) ---> India South 800 xxx yyy
dic.items()(1) ---> America North 780 xxx yyy
dic.items()(2) ---> India North 650 xxx yyy
dic.items()(3) ---> America South 810 xxx yyy

And, an element from a two-dimensional array can be accessed as follows...

dic.items()(0)(1,1) ---> India
dic.items()(0)(1,2) ---> South
dic.items()(0)(1,3) ---> 800
dic.items()(0)(1,4) ---> xxx
dic.items()(0)(1,5) ---> yyy
dic.items()(1)(1,1) ---> America
dic.items()(1)(1,2) ---> North
dic.items()(1)(1,3) ---> 780
etc...

The first temp_array = Application.Transpose(dic.Items()) returns a one-based, 5 Row by 4 Column, two-dimensional array.

India America India America
South North North South
800 780 650 810
xxx xxx xxx xxx
yyy yyy yyy yyy

The second temp_array = Application.Transpose(temp_array) returns a one-based, 4 Row by 5 Column, two-dimensional arrray.

India South 800 xxx yyy
America North 780 xxx yyy
India North 650 xxx yyy
America South 810 xxx yyy

Also, note that I've used the country and region as the key for the dictionary. I've concatenated them using '#' as the delimiter. So, for example, to return the corresponding 1 Row by 5 Column array for India and South, you would use dic.item("India#South"). And, to return a single value from the array, such as the country, you would use dic.item("India#South")(1,1).

Hope this helps!

 

[Mallesh23]

Hi Domenic,

Millions of thanks for such a wonderful explanation and solution.
It worked as expected. Thanks ?


Thanks
mg

 

[DanteAmor]

Actual Data and expected output.

Here are a couple of options with a different approach for you to consider.

Sub FilterData_1()
  Dim arr_country As Variant, arr_region As Variant
  
  arr_country = Array("India", "America")
  arr_region = Array("North", "South")
  Sheets(1).Range("A1").AutoFilter
  With Sheets(1).Range("A1:E" & Sheets(1).Range("A" & Rows.Count).End(3).Row)
    .AutoFilter Field:=1, Criteria1:=Array(arr_country), Operator:=xlFilterValues
    .AutoFilter Field:=2, Criteria1:=Array(arr_region), Operator:=xlFilterValues
    .AutoFilter Field:=3, Criteria1:=">500"
    Sheets(1).AutoFilter.Range.Copy Sheets(1).Range("I1")
  End With
  Sheets(1).Range("A1").AutoFilter
End Sub

If you want to do everything in memory, without using cells, that would make it faster.

Sub FilterData_2()
  Dim arr_country As Variant, arr_region As Variant
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  
  arr_country = Array("India", "America")
  arr_region = Array("North", "South")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(arr_country)
    dic1(arr_country(i)) = Empty
  Next
  For i = 0 To UBound(arr_region)
    dic2(arr_region(i)) = Empty
  Next
  
  a = Sheets(1).Range("A1:E" & Sheets(1).Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  For i = 1 To UBound(a)
    If dic1.exists(a(i, 1)) And dic2.exists(a(i, 2)) And a(i, 3) > 500 Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next j
    End If
  Next i
  
  Sheets(1).Range("I2").Resize(k, UBound(b, 2)).Value = b
End Sub

You could also try an advanced filter.