Словарь в словаре

Question

Я нашел старый метод http://www.techbookreport.com/tutorials/vba_dictionary2.html для выполнения словаря внутри словаря в VBA, но в модификации Excel 2013 в библиотеке Scripting, я не могу сделать работу вложенности одинаково.

Или есть?

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 

Answer 1

Рабочий код для моего листа:

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 

Answer 2

Словарь словарей:

---

Позднее связывание медленно: CreateObject ("Scripting.Dictionary")

Раннее связывание быстро: VBA Editor ->Инструменты ->Список литературы -> Добавить Microsoft Scripting время выполнения

---

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 

---