CODEWITHSUNDEEP
vbaexcel
dormanino
dormanino

Reputation: 111

Dictionary inside a Dictionary

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

Answers (2)

paul bica
paul bica

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

Dictionary of dictionaries

Upvotes: 1

dormanino
dormanino

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

Related Questions