字典四级嵌套，相信很多人没用过

chxw68

此问题是网友GovanWAng提出来的，要求建立乡、村、组、村民四级目录树，试着用其他方法做比较烦琐，后来改用字典嵌套的方法，很好的解决了问题，发现程序层次清晰、结构严谨，希望能够抛砖引玉，对大家有所帮助。
Private Sub UserForm_Initialize() '使用此段程序，必须在VBE中先加载"Micerosoft TreeView Conntrol,version6.0"控件。
  Dim d As New Dictionary '建立字典
  Dim i, j, r, c As Integer
  Dim ws As Worksheet
  Dim nodex As Node
  
  With TreeView1 '设置TreeView控件属性
    .Nodes.Clear
    .Style = 6
    .LineStyle = 1
  End With
  Set ws = Worksheets("sheet1")
  r = Cells(Rows.Count, 1).End(xlUp).Row
  arr = Range("a2:d" & r)
  n = 0
  For i = 1 To UBound(arr)
    If Not d.Exists(arr(i, 1)) Then
      Set d(arr(i, 1)) = CreateObject("scripting.dictionary") '一级字典嵌套
    End If
    If Not d(arr(i, 1)).Exists(arr(i, 2)) Then
      Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary") '二级字典嵌套
    End If
    If Not d(arr(i, 1))(arr(i, 2)).Exists(arr(i, 3)) Then
      Set d(arr(i, 1))(arr(i, 2))(arr(i, 3)) = CreateObject("scripting.dictionary") '三级字典嵌套
    End If
    If Not d(arr(i, 1))(arr(i, 2))(arr(i, 3)).Exists((arr(i, 4))) Then
      Set d(arr(i, 1))(arr(i, 2))(arr(i, 3))(arr(i, 4)) = CreateObject("scripting.dictionary") '四级字典嵌套
    End If
  Next
  TreeView1.Nodes.Clear
  Set nodex = TreeView1.Nodes.Add(, , "乡镇", "乡镇") '添加根节点
  For Each aa In d.Keys ‘在一级关键字中集合中循环
    i = i + 1
    Set nodex = TreeView1.Nodes.Add("乡镇", tvwChild, aa & i, aa) '添加二级节点
    For Each bb In d(aa).Keys ‘在二级关键字集合中循环
      j = j + 1
      Set nodex = TreeView1.Nodes.Add(aa & i, tvwChild, bb & j, bb) '添加三级节点
      For Each cc In d(aa)(bb).Keys  ‘在字典关键字集合中循环
        k = k + 1
        Set nodex = TreeView1.Nodes.Add(bb & j, tvwChild, cc & k, cc) '添加四级节点
        For Each dd In d(aa)(bb)(cc).Keys ‘在l字典关键字集合中循环
          l = l + 1
          Set nodex = TreeView1.Nodes.Add(cc & k, tvwChild, dd & l, dd) '添加五级节点
        Next
      Next
    Next
  Next
End Sub

chxw68

再提供一个两级字典嵌套的例子，很能说明字典嵌套用法的必要性，在个别情况下，使用字典能能够达到事半功倍的效果。
Sub test1()
  Dim d  As Object
  Dim i, j, r, c As Integer
  Set d = CreateObject("scripting.dictionary") '建立字典
  
  Worksheets("数据源").Select
  c = Range("a1").End(xlToRight).Column
  
  For j = 1 To c Step 2
    r = Cells(Rows.Count, j).End(xlUp).Row
    arr = Range(Cells(1, j), Cells(r, j + 1))
    If Not d.Exists(arr(1, 1)) Then
      Set d(arr(1, 1)) = CreateObject("scripting.dictionary") '建立二字典
    End If
    For i = 2 To UBound(arr)
      If Len(arr(i, 2)) <> 0 Then
        d(arr(1, 1))(arr(i, 1)) = d(arr(1, 1))(arr(i, 1)) + arr(i, 2) '给二级字典项目赋值
      End If
    Next
  Next
  
  Worksheets("结果").Select
  Cells.ClearContents
  
  For j = 0 To d.Count - 1
    Cells(1, j * 3 + 1) = d.Keys()(j) '将一级字典关键字写入行标题
    Cells(2, j * 3 + 1).Resize(d(d.Keys()(j)).Count, 1) = Application.Transpose(d(d.Keys()(j)).Keys) '将二级字典关键字写入数据表
    Cells(2, j * 3 + 2).Resize(d(d.Keys()(j)).Count, 1) = Application.Transpose(d(d.Keys()(j)).Items) '将二级字典项目写入数据表
    r = Cells(Rows.Count, j * 3 + 1).End(xlUp).Row + 1
    Cells(r, j * 3 + 1) = "合计"
    Cells(r, j * 3 + 2) = "=SUM(R[-" & r - 2 & "]C:R[-1]C)"
  Next
  Set d = Nothing
End Sub

好奇心

"Micerosoft TreeView Conntrol,version6.0"控件。
请教：以上控件在代码中能实现“引用”吗？谢谢。

chxw68

好奇心 发表于 2013-11-28 10:05
"Micerosoft TreeView Conntrol,version6.0"控件。
请教：以上控件在代码中能实现“引用”吗？谢谢。

没见这样用过。

lhsh36183

很好，谢谢楼主。得好好学习。

好奇心

chxw68 发表于 2013-11-28 08:49
再提供一个两级字典嵌套的例子，很能说明字典嵌套用法的必要性，在个别情况下，使用字典能能够达到事半功倍 ...

2楼附件下载不了，请看楼下的截图。

好奇心

下载失败信息.rar (111.92 KB, 下载次数: 99)

2013-11-28 16:10 上传

点击文件名下载附件

chxw68

好奇心 发表于 2013-11-28 16:11

我试了一下，下载没问题。

xsy我可以很好

请问可以增加一级吗，O(∩_∩)O谢谢

lee1892

楼主继续琢磨怎么让嵌套的层数是动态的，1楼的代码就会短不少，适用性也能提高。

接下来，再考虑不用字典怎么实现同样的功能。