VBA array help-

[Mallesh23]

Hi Fluff/Team,

Need your help in below situation , trying to learn array and dictionary.

I want to store below lines of code into Array and print into range.

For Each Cl In Range("k2", Range("k" & Rows.Count).End(xlUp))
If .Exists(Cl.Value) Then
Cl.Offset(, 1) = .Item(Cl.Value)(0)
Cl.Offset(, 4) = .Item(Cl.Value)(1)
End If
Next Cl

Option Explicit

Sub Workig_Code()
   
   Dim Cl As Range
   Dim i As Long     
   Dim rg As Range
  Dim arr As Variant
   Dim arr_out As Variant

   Set rg = Range("A1").CurrentRegion
   Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
   arr = rg.Value
   Dim Dict As New Scripting.dictionary
   
   arr_out = Range("K2", Range("K" & Rows.Count).End(xlUp)).Value
   
   
   'Store Required Columns 4 and 7 as items in dictionary   
   Dict.RemoveAll   
   With Dict
        For i = LBound(arr, 1) To UBound(arr, 1)
                If Not .Exists(arr(i, 2)) Then
                    .Add arr(i, 2), Array(arr(i, 4), arr(i, 7))
                End If
        Next i
       
      
    For Each Cl In Range("k2", Range("k" & Rows.Count).End(xlUp))
         If .Exists(Cl.Value) Then
            Cl.Offset(, 1) = .Item(Cl.Value)(0)
            Cl.Offset(, 4) = .Item(Cl.Value)(1)
         End If
      Next Cl
   End With      
   
End Sub

Sub Dict_Array()

    Dim i As Long
   
   
   Dim rg As Range
   Set rg = Range("A1").CurrentRegion
   Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
   
   Dim arr As Variant
   arr = rg.Value
   
   
   Dim arr_out As Variant
   arr_out = Range("K2", Range("K" & Rows.Count).End(xlUp)).Value
   
   
   'Store Required Columns 4 and 7 as items in dictionary
   Dim Dict As New Scripting.dictionary
   
   Dict.RemoveAll
   
   With Dict
        For i = LBound(arr, 1) To UBound(arr, 1)
                If Not .Exists(arr(i, 2)) Then
                    .Add arr(i, 2), Array(arr(i, 4), arr(i, 7))
                End If
        Next i
                 
              
       ' Store Both Items Column into Array and Print    ' need your help below .
              
        For i = LBound(arr_out, 1) To UBound(arr_out, 1)
              arr_out(i, 1) = .Item(arr_out(i, 1)(0))
              arr_out(i, 1) = .Item(arr_out(i, 1)(1))
        Next i
       
       
      Range("L2:L17").Value = arr_out(0)
      Range("O2:O17").Value = arr_out(1)
      
End Sub

Below is the data, expected output is in Column L and O.

Multiple Column Look up.xlsx
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	Player Name	Period	Team	Test Century	ODI Century	Total				Player Name	Team	Test Century	ODI Century	Total Century
2	Sachin Tendulkar	1989–2013	India	51	49	100				Sachin Tendulkar	India			100	=VLOOKUP(K2,$B$1:$G$43,6,0)
3	Ricky Ponting	1995–2012	Australia	41	30	71				Ricky Ponting	Australia			71
4	Virat Kohli	2008–2020	India	27	43	70				Virat Kohli	India			70	=VLOOKUP(K2,$B$1:$G$43,3,0)
5	Kumar Sangakkara	2000–2015	Sri Lanka	38	25	63				Brian Lara	West Indies			53
6	Jacques Kallis	1995–2014	South Africa	45	17	62				Rahul Dravid	India			48
7	Hashim Amla	2004–2019	South Africa	28	27	55				AB de Villiers	South Africa			47
8	Mahela Jayawardene	1997–2015	Sri Lanka	34	19	53				David Warner	Australia			42
9	Brian Lara	1990–2007	West Indies	34	19	53				Sanath Jayasuriya	Sri Lanka			42
10	Rahul Dravid	1996–2012	India	36	12	48				Chris Gayle	West Indies			27
11	AB de Villiers	2004–2018	South Africa	22	25	47				Gary Kirsten	South Africa			47
12	David Warner	2009–2020	Australia	24	18	42				Adam Gilchrist	Australia			43
13	Sanath Jayasuriya	1989–2011	Sri Lanka	14	28	42				Joe Root	England			41
14	Chris Gayle	1989–2011	West Indies	25	2	27				Kevin Pietersen	England			39
15	Shivnarine Chanderpaul	1989–2011	West Indies	30	11	41				Saeed Anwar	Pakistan			39
16	Ross Taylor	1989–2011	New Zealand	7	0	7				Allan Border	Australia			26
17	Matthew Hayden	1993–2009	Australia	30	10	40				Don Bradman	Australia			56
18	Gary Kirsten	1993–2004	South Africa	21	26	47
19	Kane Williamson	1993–2004	New Zealand	13	30	43
20	Adam Gilchrist	1996–2008	Australia	17	26	43
21	Joe Root	2004–2014	England	16	25	41
22	Kevin Pietersen	2004–2014	England	23	16	39
23	Javed Miandad	1975–1996	Pakistan	23	15	38
24	Aravinda de Silva	1975–1996	Sri Lanka	11	24	35
25	Saeed Anwar	1975–1996	Pakistan	20	19	39
26	Gordon Greenidge	1974–1991	West Indies	19	30	49
27	Allan Border	1974–1991	Australia	3	23	26
28	Don Bradman	1928–1948	Australia	29	27	56
29	Mohammad Azharuddin	1928–1948	India	7	15	22
30	Graham Gooch	1975–1995	England	20	18	38
31	Greg Chappell	1970–1984	Australia	24	28	52
32	Marvan Atapattu	1970–1984	Sri Lanka	11	27	38
33	Nathan Astle	1970–1984	New Zealand	16	20	36
34	Andrew Strauss	1970–1984	England	6	25	31
35	Garfield Sobers	1970–1984	West Indies	26	29	55
36	David Boon	1970–1984	Australia	5	30	35
37	Marcus Trescothick	1970–1984	England	12	17	29
38	Ian Bell	1970–1984	England	4	25	29
39	David Gower	1970–1984	England	18	22	40
40	Shikhar Dhawan	2010–2020	India	7	22	29
41	Geoffrey Boycott	1964–1982	England	22	22	44
42	Justin Langer	1964–1982	Australia	23	21	44
43	V. V. S. Laxman	2000-2014	India	6	23	29
Sheet1

Cell Formulas
Range	Formula
L2:L17	L2	=VLOOKUP(K2,$B$1:$G$43,3,0)
O2:O17	O2	=VLOOKUP(K2,$B$1:$G$43,6,0)

 

[Mallesh23]

Hi Team,

I reattmpted I am getting Result as expected, But Can we shorten the Code,

I am getting result , but I using multiple loops here.

Sub Dict_Array()
    Dim i As Long  
   Dim rg As Range
   Set rg = Range("A1").CurrentRegion
   Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
  
   Dim arr As Variant
   arr = rg.Value
  
  
   Dim arr_out As Variant
   arr_out = Range("K2", Range("K" & Rows.Count).End(xlUp)).Value
  
  
   'Store Required Columns 4 and 7 as items in dictionary
   Dim dict As New Scripting.Dictionary
  
   dict.RemoveAll
  
   With dict
  
'======================================================================'======================================================================
         'Store Column 4 in Items and Print
         For i = LBound(arr, 1) To UBound(arr, 1)
                 If Not .Exists(arr(i, 2)) Then
                     .Add arr(i, 2), arr(i, 4) ', arr(i, 7))
                 End If
         Next i
                 
              
        ' Store Both Single Column into Array and Print
         For i = LBound(arr_out, 1) To UBound(arr_out, 1)
               arr_out(i, 1) = .Item(arr_out(i, 1))
         Next i
        
         End With
      
       Range("L2").Resize(UBound(arr_out, 1)).Value = arr_out
     
'======================================================================
            dict.RemoveAll
            'Store Column 7 in Items and Print
            arr_out = Range("K2", Range("K" & Rows.Count).End(xlUp)).Value
      
       With dict
         For i = LBound(arr, 1) To UBound(arr, 1)
                 If Not .Exists(arr(i, 2)) Then
                     .Add arr(i, 2), arr(i, 7) ', arr(i, 7))
                 End If
         Next i
                 
              
        ' Store Both Single Column into Array and Print
         For i = LBound(arr_out, 1) To UBound(arr_out, 1)
               arr_out(i, 1) = .Item(arr_out(i, 1))
         Next i   
                
          Range("O2").Resize(UBound(arr_out, 1)).Value = arr_out
     
      End With
                
End Sub

Thanks
mg