vba - add collection to Dictionary - dictionnary to worksheet

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
983
Office Version
  1. 2010
Platform
  1. Windows
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
ABCDEFGH
112701159191913741426103310431462
211621579194616441951187110541665
318511699177616101722122117021995
415521591104710081338119717451802
513371635183615801724140917491407
614261458199819681773119110061749
718381860144613401744198818621034
819021696164417891518152617721360
911381455181718381280120210581940
1017771127123118971430195616531324
1116181238158212471648115917091716
1211591752180610151510150811601299
1310741537177213471380143414111707
1418941200182014311593158010591048
1516121834124315601103186816461681
1616061146108818231221156713501932
1716601195178312641448109718701652
1813391772165310651825175712791731
1912191556122310471502137710531839
2019661878187716751826147213471493
2115451805172812441986179919191109
Sheet1



VBA Code:
[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]
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Since you're using late binding, the Items method of the Dictionary object should include empty brackets in order to return the array...

VBA Code:
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...

VBA Code:
dict.items()(0)

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

VBA Code:
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.
 
Upvote 0
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

VBA Code:
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


VBA Code:
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
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
Sorry, but it's unclear to me how you want the resulting data laid out. Can you post the actual resulting data?
 
Upvote 0
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.

VBA Code:
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
ABCDEFGHIJKLM
1CountryRegionSalesProductBonusCountryRegionSalesProductBonus
2Sri LankaSouth610xxxyyyIndiaSouth800xxxyyy
3IndiaSouth800xxxyyyAmericaNorth780xxxyyy
4AustraliaNorth720xxxyyyIndiaNorth650xxxyyy
5AmericaNorth780xxxyyyAmericaSouth810xxxyyy
6GermanayWest860xxxyyy
7FRANCEEAST970xxxyyy
8IndiaNorth650xxxyyy
9Pakistan440xxxyyy
10AmericaEast500xxxyyy
11BrazilWest520xxxyyy
12AmericaSouth810xxxyyy
13BrazilEAST650xxxyyy
14AmericaSouth400xxxyyy
15AustraliaSouth720xxxyyy
16IndiaWest610xxxyyy
Sheet1



Thanks
mg
 
Upvote 0
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.

VBA Code:
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!
 
Upvote 0
Hi Domenic,

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


Thanks
mg
 
Upvote 0
Actual Data and expected output.

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

VBA Code:
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.
VBA Code:
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.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top