Reputation: 111
I found an old method http://www.techbookreport.com/tutorials/vba_dictionary2.html to perform a dictionary inside a dictionary in VBA but in Excel 2013 modification in the Scripting library, I can't make the nesting work the same way.
Or is there?
Sub dict()
Dim ws1 As Worksheet: Set ws1 = Sheets("BM")
Dim family_dict As New Scripting.Dictionary
Dim bm_dict As New Scripting.Dictionary
Dim family As String, bm As String
Dim i
Dim ws1_range As Range
Dim rng1 As Range
With ws1
Set ws1_range = .Range(Cells(2, 1).Address & ":" & Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Address)
End With
For Each rng1 In ws1_range
family = ws1.Cells(rng1.Row, 1)
bm = ws1.Cells(rng1.Row, 2)
If family_dict.Exists(family) Then
Set bm_dict = family_dict(family)("scripting.dictionary")
If bm_dict.Exists(bm) Then
Else
bm_dict.Add bm, Empty
End If
Else
family_dict.Add family, Empty
Set bm_dict = family_dict(family)("scripting.dictionary")
If bm_dict.Exists(bm) Then
Else
bm_dict.Add bm, Empty
End If
End If
For Each i In family_dict.Keys: Debug.Print i: Next
For Each i In bm_dict.Keys: Debug.Print i: Next
For Each i In bm_dict.Items: Debug.Print i: Next
Debug.Print bm_dict.Count
Next
End Sub
Upvotes: 1
Views: 2949
Reputation: 10705
Dictionary of dictionaries:
Late binding is slow:
CreateObject("Scripting.Dictionary")Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime
Option Explicit
Public Sub nestedList()
Dim ws As Worksheet, i As Long, j As Long, x As Variant, y As Variant, z As Variant
Dim itms As Dictionary, subItms As Dictionary 'ref to "Microsoft Scripting Runtime"
Set ws = Worksheets("Sheet1")
Set itms = New Dictionary
For i = 2 To ws.UsedRange.Rows.Count
Set subItms = New Dictionary '<-- this should pick up a new dictionary
For j = 2 To ws.UsedRange.Columns.Count
' Key: "Property 1", Item: "A"
subItms.Add Key:=ws.Cells(1, j).Value2, Item:=ws.Cells(i, j).Value2
Next
' Key: "Item 1", Item: subItms
itms.Add Key:=ws.Cells(i, 1).Value2, Item:=subItms
Set subItms = Nothing '<-- releasing previous object
Next
MsgBox "Row 5, Column 4: ---> " & itms("Row 5")("Column 4")
End Sub
Upvotes: 1
Reputation: 111
Working code for my Sheet:
Sub dict()
Dim ws1 As Worksheet: Set ws1 = Sheets("BM")
Dim family_dict As Dictionary, bm_dict As Dictionary
Dim i, j
Dim ws1_range As Range
Dim rng1 As Range, rng2 As Range
With ws1
Set ws1_range = .Range(Cells(2, 1).Address & ":" & Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Address)
End With
Set family_dict = New Dictionary
For Each rng1 In ws1_range
If Not family_dict.Exists(Key:=ws1.Cells(rng1.Row, 1).Value2) Then
Set bm_dict = New Dictionary
For Each rng2 In ws1_range
If rng2 = rng1 Then
If Not bm_dict.Exists(Key:=ws1.Cells(rng2.Row, 2).Value2) Then
bm_dict.Add Key:=ws1.Cells(rng2.Row, 2).Value2, Item:=Empty
End If
End If
Next
family_dict.Add Key:=ws1.Cells(rng1.Row, 1).Value2, Item:=bm_dict
Set bm_dict = Nothing
End If
Next
'---test---immediate window on---
For Each i In family_dict.Keys: Debug.Print i: For Each j In family_dict(i): Debug.Print j: Next: Next
End Sub
Upvotes: 2