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]

 

[Mallesh23]

Hi Danteamor,

Thanks for providing another option ,
I liked Array approach . Can you add comment to understand it perfectly. Thanks

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


Thanks
mg

 

[Domenic]

You're very welcome, glad I could help.

And, it looks like Dante has given you a few options, so that's great.

Cheers!

 

[DanteAmor]

Can you add comment to understand it perfectly

How about:

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")
  
  'Put the countries in the dictionary
  For i = 0 To UBound(arr_country)
    dic1(arr_country(i)) = Empty
  Next
  'Put the regions in the dictionary
  For i = 0 To UBound(arr_region)
    dic2(arr_region(i)) = Empty
  Next
  
  'populate array 'a' with range of cells
  a = Sheets(1).Range("A1:E" & Sheets(1).Range("A" & Rows.Count).End(3).Row).Value2
  'resize the output
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  'cycle from 0 to number of rows in array 'a'
  For i = 1 To UBound(a)
    'if country 'a(i, 1)' is in the country dictionary. And
    'the region 'a(i, 2)' is in the region dictionary. And
    'sales are greater than 500.
    If dic1.exists(a(i, 1)) And dic2.exists(a(i, 2)) And a(i, 3) > 500 Then
      'the variable 'k' counts the rows in the output.
      k = k + 1
      'cycle from 1 to the number of columns in array 'a'
      For j = 1 To UBound(a, 2)
        'fill the output in array 'b'(row, column) = with the value of array 'a'
        b(k, j) = a(i, j)
      Next j
    End If
  Next i
  'pass array 'b' to cells
  'starts in cell I2, resizes the output to the number of rows 'k' and the number of columns in array 'b'
  Sheets(1).Range("I2").Resize(k, UBound(b, 2)).Value = b
End Sub

 

[Mallesh23]

Hi Dante,

Thanks once again , for adding comment to make it still more simpler. thanks ?


Thanks
mg

 

[Rick Rothstein]

If I am not mistaken, I believe this code will also do what the OP asked for...

Sub FilterData()
  Dim LastRow As Long
  LastRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
  Sheets(1).Range("C2:C" & LastRow) = Evaluate(Replace(Replace("IF(((@A2:A#=""India"")+(@A2:A#=""America""))*((@B2:B#=""North"")+(@B2:B#=""South""))*(@C2:C#>500),""=""&@C2:C#,@C2:C#)", "#", LastRow), "@", Sheets(1).Name & "!"))
  Intersect(Sheets(1).Columns("C").SpecialCells(xlFormulas).EntireRow, Sheets(1).Columns("A:E")).Copy
  Sheets(1).Range("I2").PasteSpecial xlValues
  Application.CutCopyMode = False
  Sheets(1).Columns("C").Replace "=", "", xlPart, , , , False, False
End Sub

 

[DanteAmor]

Hi Dante,

Thanks once again , for adding comment to make it still more simpler

Glad we could help & thanks for the feedback