VBA Dictionary - Subscript out of range

[Mallesh23]

Hi Team,

I am Learning dictionary. In Below example getting error message subscript out of Range.for below line.

ar_Eng(i, 1) = .Item(ary_find(i, 1))(0)

I know only one approach this get the answer.
are there any other way to achieve the task using dictionary.

Below is my Attempted Code.

Sub Print_dict_Dynamically()
  Dim dict As New Scripting.Dictionary
  Dim i As Long
 
  Dim rg As Range
  Set rg = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion
 
  Dim ary As Variant
  ary = rg.Offset(1).Resize(rg.Rows.Count - 1).Value2
 
  Dim ary_find As Variant
  ary_find = Range("H2:H7").Value2
 
 
  With dict
    .CompareMode = TextCompare
    For i = LBound(ary, 1) To UBound(ary, 1)
      If Not .Exists(ary(i, 1)) Then
        .Add ary(i, 1), Array(ary(i, 2), ary(i, 3), ary(i, 4))
      End If
    Next i
   
  
    Dim ar_Eng As Variant
    Dim ar_Math As Variant
    Dim ar_Sci As Variant
     
   ReDim ar_Eng(LBound(ary_find, 1), UBound(ary_find), 1)
   ReDim ar_Math(LBound(ary_find, 1), UBound(ary_find), 1)
   ReDim ar_Sci(LBound(ary_find, 1), UBound(ary_find), 1)
  
'Store into array variable
For i = LBound(ary_find, 1) To UBound(ary_find, 1)
        If .Exists(ary_find(i, 1)) Then
           ar_Eng(i, 1) = .Item(ary_find(i, 1))(0)  'Getting error at subscript out of dictionary
            ar_Math(i, 1) = .Item(ary_find(i, 1))(0)
           ar_Sci(i, 1) = .Item(ary_find(i, 1))(0)
        End If

Next i

End With

'Print Items
With ThisWorkbook.Worksheets(1)
    .Range("I2").Resize(UBound(ary_find)).Value = ar_rng
    .Range("J2").Resize(UBound(ary_find)).Value = ar_Math
    .Range("k2").Resize(UBound(ary_find)).Value = ar_Sci
End With
 

'ThisWorkbook.Worksheets(1).Range("I2").Resize(dict.Count, 3).Value = Application.Index(dict.Items, 0, 0)
 
  MsgBox "Macro Success"
Set dict = Nothing
 
End Sub

Below is the Table with expected output in Range("I:K)

Book11.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Name	English	Maths	Science	Total			Name	English	Maths	Science
2	Sachin	92	62	94	248			Sachin	92	62	94
3	Dhoni	80	66	90	236			Dhoni	80	66	90
4	Yuvraj	62	83	94	239			Adam Gilchrist	97	93	83
5	Virat	99	79	97	275			Gayle	70	96	85
6	Steve waugh	81	88	92	261			Fleming	99	96	85
7	Ricky Ponting	66	63	95	224
8	Adam Gilchrist	97	93	83	273
9	Gayle	70	96	85	251
10	Fleming	99	96	85	280
Sheet1

Thanks
mg

 

[Fluff]

This line (& the next two)

ReDim ar_Eng(LBound(ary_find, 1), UBound(ary_find), 1)

should be

ReDim ar_Eng(LBound(ary_find, 1) to UBound(ary_find), 1 to 1)

 

[Mallesh23]

Hi Fluff,

Perfect ! it worked.
am I using very lengthy approach to get the output ,
are there any other way using to get the output using dictionary.

Sub Print_dict_Dynamically()
  Dim dict As New Scripting.Dictionary
  Dim i As Long
 
  Dim rg As Range
  Set rg = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion
 
  Dim ary As Variant
  ary = rg.Offset(1).Resize(rg.Rows.Count - 1).Value2
 
  Dim ary_find As Variant
  ary_find = Range("H2:H7").Value2
 
 
  With dict
    .CompareMode = TextCompare
    For i = LBound(ary, 1) To UBound(ary, 1)
      If Not .Exists(ary(i, 1)) Then
        .Add ary(i, 1), Array(ary(i, 2), ary(i, 3), ary(i, 4))
      End If
    Next i
   
  
    Dim ar_Eng As Variant
    Dim ar_Math As Variant
    Dim ar_Sci As Variant
     
    ReDim ar_Eng(LBound(ary_find, 1) To UBound(ary_find), 1 To 1)
   ReDim ar_Math(LBound(ary_find, 1) To UBound(ary_find), 1 To 1)
   ReDim ar_Sci(LBound(ary_find, 1) To UBound(ary_find), 1 To 1)
  

For i = LBound(ary_find, 1) To UBound(ary_find, 1)
        If .Exists(ary_find(i, 1)) Then
           ar_Eng(i, 1) = .Item(ary_find(i, 1))(0) 
            ar_Math(i, 1) = .Item(ary_find(i, 1))(1)
           ar_Sci(i, 1) = .Item(ary_find(i, 1))(2)
        Else
       
        ar_Eng(i, 1) = "Not Found" 
            ar_Math(i, 1) = "Not Found"
           ar_Sci(i, 1) = "Not Found"
        End If

Next i

End With

With ThisWorkbook.Worksheets(1)
    .Range("I2").Resize(UBound(ary_find)).Value = ar_Eng
    .Range("J2").Resize(UBound(ary_find)).Value = ar_Math
    .Range("k2").Resize(UBound(ary_find)).Value = ar_Sci
End With
 
 
  Set dict = Nothing
 
'ThisWorkbook.Worksheets(1).Range("I2").Resize(dict.Count, 3).Value = Application.Index(dict.Items, 0, 0)
 
  MsgBox "Macro Success"
 
End Sub

Thanks
mg

 

[Fluff]

Just depends on what you want to do, there are always multiple different ways.

 

[Mallesh23]

Hi Fluff,

Agreed there are multiple solutions for a single task.

I come across this scenario multiple times , hence want to create a Dynamic function for it.
is it possible?..

With dict
    .CompareMode = TextCompare
    For i = LBound(ary, 1) To UBound(ary, 1)
      If Not .Exists(ary(i, 1)) Then
        .Add ary(i, 1), Array(ary(i, 2), ary(i, 3), ary(i, 4))
      End If
    Next i
 end with

'Attempted Function (expected item Columns 1 to 5)

Function Store_Dictionary(byval ary as variant, lookup_key as long, items as long) as dictionary

Dim i as long
Dim dict as new scripting dictionary

With dict
    .CompareMode = TextCompare
    For i = LBound(ary, 1) To UBound(ary, 1)
      If Not .Exists(ary(i, lookup_key)) Then
        If Items = 4 Then
            .Add ary(i, lookup_key), Array(ary(i, 2), ary(i, 3), ary(i, 4), ary(i, 5))
        ElseIf Items = 3 Then
            .Add ary(i, lookup_key), Array(ary(i, 2), ary(i, 3), ary(i, 4))
        ElseIf Items = 1 Then
            .Add ary(i, lookup_key), Array(ary(i, 2), ary(i, 3))
        Else
            .Add ary(i, lookup_key), Array(ary(i, 2))
        End If


    End If


      End If
    Next i
End With


Store_Dictionary = Dict

end function

 

[Fluff]

You could do something like

Sub Mallesh()
   Dim Ary As Variant, Tmp As Variant
   Dim r As Long, c As Long
   
   Ary = Sheet1.Range("a1").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            ReDim Tmp(1 To UBound(Ary, 2) - 1)
            For c = 2 To UBound(Ary, 2)
               Tmp(c - 1) = Ary(r, c)
            Next c
            .Add Ary(r, 1), Tmp
         End If
      Next r
      Sheet1.Range("K2").Resize(.count).Value = Application.Transpose(.Keys)
      Sheet1.Range("l2").Resize(.count, UBound(Tmp)).Value = Application.Index(.items, 0, 0)
   End With
End Sub

 

[Mallesh23]

Hi Fluff,

Thanks once again for, Providing ,one more option , will practice on it.


Thanks
mg

 

[Fluff]

You're welcome & thanks for the feedback.