用一个字典代替字典嵌套完成多级联动功能

zhaogang1960

用一个字典代替字典嵌套完成多级联动功能

用字典嵌套(字典套字典)可以完成多级联动功能，用起来很方便，在数据量不是太大、嵌套级数不多的情况下，速度还是可以的，但如果数据量太大，或嵌套级数太多时，速度会变得很慢，下面用几个例子说明用一个字典，或几个字典代替字典嵌套完成多级联动功能。

一、三级联动列表框

原代码如下(lj1226189坛友所写)

Dim d1 As New Dictionary

Dim d2 As New Dictionary

Dim D4 As New Dictionary

Private Sub UserForm_Initialize()

tt = Timer

   Dim n As Long, i As Long, arr

    n= Sheets("SHEET1").[a65536].End(xlUp).Row

   arr = Sheets("SHEET1").[a1].Resize(n, 3)

   Application.ScreenUpdating = False

   On Error Resume Next

   For i = 1 To n

       D4.Add arr(i, 1) & "", ""

       xx = arr(i, 1) & ""

       yy = arr(i, 2) & ""

       zz = arr(i, 3) & ""

       xh = arr(i, 1) & arr(i, 2)

       If d1.Exists(xx) = False Then Set d1(xx) = New Dictionary '字典嵌套

       d1(xx)(yy) = zz

       If d2.Exists(xh) = False Then Set d2(xh) = New Dictionary '字典嵌套

       d2(xh)(zz) = zz

   Next

   UserForm1.ListBox1.List = d1.Keys

   Application.ScreenUpdating = True

   MsgBox Timer - tt

End Sub

用一个字典实现代码如下：

Dim d As Object

Private Sub UserForm_Initialize()

tt = Timer

   Dim i As Long, arr

   arr = Sheets("Sheet1").Range("A1").CurrentRegion

   Set d = CreateObject("scripting.dictionary")

   For i = 2 To UBound(arr)

       If InStr(d(arr(i, 1)) & ",", "," & arr(i, 2)& ",") = 0 Then d(arr(i, 1)) = d(arr(i, 1)) & ","& arr(i, 2) '如果字典条目中不含有该二级项目，则把一级项目添加到字典键值，该二级项目添加到字典条目，和原条目用逗号隔开

       If InStr(d(arr(i, 1) & vbTab & arr(i, 2)) & ",","," & arr(i, 3) & ",") = 0 Then d(arr(i, 1) &vbTab & arr(i, 2)) = d(arr(i, 1) & vbTab & arr(i, 2)) &"," & arr(i, 3)  '如果字典条目中不含有该三级项目，则把一级项目和二级项目用vbTab连接起来添加到字典键值，把三级项目添加到字典条目，和原条目用逗号隔开

   Next

   ListBox1.List = Filter(d.Keys, vbTab, False) '去掉含有vbTab的元素

   MsgBox Timer - tt

End Sub

附件一——三级联动列表框.rar (87.58 KB, 下载次数: 6872)

2013-11-30 04:03 上传

点击文件名下载附件

该贴已经同步到 zhaogang1960的微博

zhaogang1960

二、用TreeView控件建立目录树
字典嵌套代码由chxw68坛友所写，原代码如下：
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 + 1
          Set nodex = TreeView1.Nodes.Add(cc & k, tvwChild, dd & l, dd) '添加五级节点
        Next
      Next
    Next
  Next
End Sub

用一个字典实现代码如下：
Private Sub UserForm_Initialize()
'本例仅说明可以用一个字典实现多级联动，没有比较速度，因为时间主要浪费在向TreeView写数据
    Dim d As New Dictionary '建立字典
    Dim nodex As Node
    Dim arr, aa, bb, cc, dd, i&, j&
    With TreeView1 '设置TreeView控件属性
        .Nodes.Clear
        .Style = 6
        .LineStyle = 1
        arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
        For i = 1 To UBound(arr)
            For j = 1 To 3 '从第一级到倒数第二级，用循环表示
                If j = 1 Then s = arr(i, j) Else s = s & vbTab & arr(i, j)
                If Not d.Exists(s) Then
                    d(s) = arr(i, j + 1)
                Else
                    If InStr("," & d(s) & ",", "," & arr(i, j + 1) & ",") = 0 Then d(s) = d(s) & "," & arr(i, j + 1)
                End If
            Next
            '以上用For循环实现下面注释部分设置字典
'            s = arr(i, 1)
'            If Not d.Exists(s) Then
'                d(s) = arr(i, 2)
'            Else
'                If InStr("," & d(s) & ",", "," & arr(i, 2) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 2)
'            End If
'            s = s & vbTab & arr(i, 2)
'            If Not d.Exists(s) Then
'                d(s) = arr(i, 3)
'            Else
'                If InStr("," & d(s) & ",", "," & arr(i, 3) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 3)
'            End If
'            s = s & vbTab & arr(i, 3)
'            If Not d.Exists(s) Then
'                d(s) = arr(i, 4)
'            Else
'                If InStr("," & d(s) & ",", "," & arr(i, 4) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 4)
'            End If
        Next
        .Nodes.Clear
        Set nodex = .Nodes.Add(, , "乡镇", "乡镇") '添加根节点
        For Each aa In Filter(d.Keys, vbTab, False) '字典键值不含vbTab数组
            i = i + 1
            Set nodex = .Nodes.Add("乡镇", tvwChild, aa & i, aa) '添加二级节点
            For Each bb In Split(d(aa), ",")
                j = j + 1
                Set nodex = .Nodes.Add(aa & i, tvwChild, bb & j, bb) '添加三级节点
                For Each cc In Split(d(aa & vbTab & bb), ",")
                    k = k + 1
                    Set nodex = .Nodes.Add(bb & j, tvwChild, cc & k, cc) '添加四级节点
                    For Each dd In Split(d(aa & vbTab & bb & vbTab & cc), ",")
                        l = l + 1
                        Set nodex = .Nodes.Add(cc & k, tvwChild, dd & l, dd) '添加五级节点
                    Next
                Next
            Next
        Next
    End With
End Sub


附件二——建立目录树(字典四级嵌套和用一个字典分别实现).rar (23.35 KB, 下载次数: 2543)

2013-11-30 04:37 上传

点击文件名下载附件

建立目录树(字典四级嵌套和用一个字典分别实现从第一级到倒数第二级，用循环表示).rar (18.86 KB, 下载次数: 2198)

2013-12-6 01:47 上传

点击文件名下载附件

zhaogang1960

三、左键三级菜单，新加一个附件《四级菜单显示最后两级到单元格》
字典嵌套代码如下：
Sub CreatMe() '字典嵌套生成左键树型菜单
    Dim d As Object, i&, j&, k, k2, t, a, l&, arr, x As Object
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet1").Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary") '字典嵌套
        If Len(arr(i, 2)) Then d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) & "," & arr(i, 3) '如果二级分类不为空，把三级分类添加到字典条目，并用逗号隔开
    Next
    k = d.keys '一级分类
    On Error Resume Next
    Application.CommandBars("树型菜单").Delete '删除可能存在的"树型菜单"菜单
    With Application.CommandBars.Add("树型菜单", msoBarPopup)
        For i = 0 To UBound(k)
            With .Controls.Add(Type:=IIf(d(k(i)).Count, msoControlPopup, msoControlButton))
                .Caption = k(i)
                .OnAction = IIf(d(k(i)).Count, "", "'显示在活动单元格 """ & k(i) & """'")
                .BeginGroup = True '分组显示
                k2 = d(k(i)).keys '二级分类
                t = d(k(i)).items '三级分类，每个三级分类用逗号隔开
                For j = 0 To UBound(k2)
                    a = Split(t(j), ",")
                    With .Controls.Add(Type:=IIf(Len(t(j)) > UBound(a), msoControlPopup, msoControlButton))
                        .Caption = k2(j)
                        .OnAction = IIf(Len(t(j)) > UBound(a), "", "'显示在活动单元格 """ & k2(j) & """'")
                        For l = 1 To UBound(a)
                            If Len(a(l)) Then
                                With .Controls.Add(Type:=msoControlButton)
                                    .Caption = a(l)
                                    .OnAction = "'显示在活动单元格 """ & a(l) & """'"
                                End With
                            End If
                        Next
                    End With
                Next
            End With
        Next
    End With
End Sub

Sub 显示在活动单元格(s$)
    ActiveCell.Value = s
End Sub

一个字典实现如下：
Sub CreatMe() '一个字典生成左键树型菜单
    Dim d As Object, i&, j&, k, k2, t2, a3, l&, arr, x As Object
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet1").Range("A1").CurrentRegion
    For i = 2 To UBound(arr)
        If InStr(d(arr(i, 1)) & ",", "," & arr(i, 2) & ",") = 0 Then d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2) '如果字典条目中不含有该二级分类，则把一级分类添加到字典键值，该二级分类添加到字典条目，和原条目用逗号隔开
        If Len(arr(i, 2)) Then d(arr(i, 1) & vbTab & arr(i, 2)) = d(arr(i, 1) & vbTab & arr(i, 2)) & "," & arr(i, 3) '如果二级分类不为空，则把一级分类和二级分类用vbTab连接起来添加到字典键值，把三级分类添加到字典条目，和原条目用逗号隔开
    Next
    k = Filter(d.keys, vbTab, False) '一级分类，不含vbTab
    On Error Resume Next
    Application.CommandBars("树型菜单").Delete '删除可能存在的"树型菜单"菜单
    With Application.CommandBars.Add("树型菜单", msoBarPopup)
        For i = 0 To UBound(k)
            t2 = d(k(i)) '二级分类，每个二级分类用逗号隔开
            a2 = Split(t2, ",") '二级分类数组
            With .Controls.Add(Type:=IIf(Len(t2) > UBound(a2), msoControlPopup, msoControlButton)) '二级分类t2都是逗号，即没有实际项目，则msoControlButton
                .Caption = k(i)
                .OnAction = IIf(Len(t2) > UBound(a2), "", "显示在活动单元格")
                .BeginGroup = True '分组显示
                For j = 1 To UBound(a2) '逐个二级分类
                    If Len(a2(j)) Then '如果二级分类不为空
                        t3 = d(k(i) & vbTab & a2(j)) '三级分类，每个三级分类用逗号隔开
                        a3 = Split(t3, ",") '三级分类数组
                        With .Controls.Add(Type:=IIf(Len(t3) > UBound(a3), msoControlPopup, msoControlButton))
                            .Caption = a2(j)
                            .OnAction = IIf(Len(t3) > UBound(a3), "", "显示在活动单元格")
                            For l = 1 To UBound(a3)
                                If Len(a3(l)) Then
                                    With .Controls.Add(Type:=msoControlButton)
                                        .Caption = a3(l)
                                        .OnAction = "显示在活动单元格"
                                    End With
                                End If
                            Next
                        End With
                    End If
                Next
            End With
        Next
    End With
End Sub

Sub 显示在活动单元格()

   ActiveCell.Value = Application.CommandBars.ActionControl.Caption

End Sub

附件三——1左键三级菜单(字典嵌套).rar (44.59 KB, 下载次数: 1869)

2013-11-30 04:10 上传

点击文件名下载附件

附件一——2左键三级菜单(只用一个字典).rar (45.76 KB, 下载次数: 1822)

2013-11-30 04:10 上传

点击文件名下载附件

四级菜单显示最后两级到单元格.rar (45.04 KB, 下载次数: 2025)

2013-12-6 00:19 上传

点击文件名下载附件

zhaogang1960

四、根据姓名统计出编号出现的记录条数
字典嵌套代码如下：
Sub 字典嵌套()
    Dim d As Object, arr, brr(), i&, j&, lc&, k, t, sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            arr = sh.UsedRange
            For i = 2 To sh.[a65536].End(xlUp).Row
                If Len(arr(i, 1)) Then
                    If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("Scripting.Dictionary") '字典嵌套
                    d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + 2 '同一个姓名的编号出现的次数，这里为了写入数组方便，每出现一次+2，实际上是实现次数的2倍
                End If
            Next
        End If
    Next
    k = d.keys
    ReDim brr(0 To UBound(k), 2 To 250)
    For j = 0 To UBound(k)
        t = d(k(j)).items
        For i = 0 To UBound(t)
            brr(j, t(i)) = brr(j, t(i)) + 1
            If t(i) > lc Then lc = t(i)
        Next
    Next
    With Sheets("汇总")
        .[a2:a60000] = ""
        .UsedRange.Offset(1, 2).ClearContents
        .[a2].Resize(j) = WorksheetFunction.Transpose(k)
        .[c2].Resize(j, lc + 1) = brr
        Cells(j + 2, 1) = "合计"
        Cells(j + 2, 2).Resize(, lc + 1) = "=SUM(R2C:R" & j + 1 & "C)"
        For i = 3 To lc + 1 Step 2
            Cells(2, i + 1).Resize(j + 1) = "=RC" & i & "/RC2*100"
        Next
    End With
End Sub
两个字典实现代码如下：
Sub 两个字典()
    Dim d As Object, ds As Object, arr, brr&(), crr(), i&, j&, m&, c&, lc&, k, t, r, sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            arr = sh.UsedRange
            For i = 2 To sh.[a65536].End(xlUp).Row
                If Len(arr(i, 1)) Then
                    r = d(arr(i, 1))
                    If r = "" Then
                        m = m + 1
                        d(arr(i, 1)) = m
                        r = m
                    End If
                    ds(r & vbTab & arr(i, 2)) = ds(r & vbTab & arr(i, 2)) + 2
                End If
            Next
        End If
    Next
    k = ds.keys
    t = ds.items
    ReDim brr(1 To m, 2 To 250)
    For i = 0 To UBound(k)
        j = Split(k(i), vbTab)(0)
        c = t(i)
        brr(j, c) = brr(j, c) + 1
        If c > lc Then lc = c
    Next
    With Sheets("汇总")
        .[a2:a60000] = ""
        .UsedRange.Offset(, 2).ClearContents
        .UsedRange.Borders.LineStyle = xlNone
        .[a2].Resize(m) = WorksheetFunction.Transpose(d.keys)
        .[c2].Resize(m, lc) = brr
        .Cells(m + 2, 1) = "合计"
        .Cells(m + 2, 2).Resize(, lc + 1) = "=SUM(R2C:R" & m + 1 & "C)"
        For i = 3 To lc + 1 Step 2
            .Cells(2, i + 1).Resize(m + 1) = "=RC" & i & "/RC2*100"
            v = v + 1
            .Cells(1, i) = "出现" & Application.Text(v, "[DBNum1]") & "次"
            .Cells(1, i + 1) = "占比"
        Next
        .[a1].CurrentRegion.Borders.LineStyle = 1
    End With
End Sub

附件四——根据姓名统计出编号出现的记录条数(字典嵌套和用两个字典分别实现).rar (14.04 KB, 下载次数: 2111)

2013-11-30 04:12 上传

点击文件名下载附件

zhaogang1960

五、ComboBox控件四级联动，本题目目的在于测试两种代码的速度
字典嵌套代码如下：
Dim d As Object

Private Sub ComboBox1_Change()
    If ComboBox1.ListIndex = -1 Then Exit Sub
    ComboBox2.Clear
    ComboBox3.Clear
    ComboBox4.Clear
    ComboBox2.List = d(ComboBox1.Value).Keys
End Sub

Private Sub ComboBox2_Change()
    If ComboBox2.ListIndex = -1 Then Exit Sub
    ComboBox3.Clear
    ComboBox4.Clear
    ComboBox3.List = d(ComboBox1.Value)(ComboBox2.Value).Keys
End Sub

Private Sub ComboBox3_Change()
    If ComboBox3.ListIndex = -1 Then Exit Sub
    ComboBox4.Clear
    ComboBox4.List = d(ComboBox1.Value)(ComboBox2.Value)(ComboBox3.Value).Keys
End Sub

Private Sub CommandButton1_Click()
  Unload UserForm1
End Sub

Private Sub UserForm_Initialize()
    tt = Timer
    Dim i&, arr
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")        '一级字典嵌套
        If Not d(arr(i, 1)).Exists(arr(i, 2)) Then Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")        '二级字典嵌套
        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")        '三级字典嵌套
        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")        '四级字典嵌套
    Next
    ComboBox1.List = d.Keys
    MsgBox Timer - tt
End Sub

一个字典实现代码如下：
Dim d As Object

Private Sub ComboBox1_Change()
    If ComboBox1.ListIndex = -1 Then Exit Sub
    ComboBox2.Clear
    ComboBox3.Clear
    ComboBox4.Clear
    ComboBox2.List = Split(d(ComboBox1.Value), ",")
End Sub

Private Sub ComboBox2_Change()
    If ComboBox2.ListIndex = -1 Then Exit Sub
    ComboBox3.Clear
    ComboBox4.Clear
    ComboBox3.List = Split(d(ComboBox1.Value & vbTab & ComboBox2.Value), ",")
End Sub

Private Sub ComboBox3_Change()
    If ComboBox3.ListIndex = -1 Then Exit Sub
    ComboBox4.Clear
    ComboBox4.List = Split(d(ComboBox1.Value & vbTab & ComboBox2.Value & vbTab & ComboBox3.Value), ",")
End Sub

Private Sub CommandButton1_Click()
  Unload UserForm1
End Sub

Private Sub UserForm_Initialize()
    tt = Timer
    Dim nodex As Node
    Dim arr, i&
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(arr)
        s = arr(i, 1)
        If Not d.Exists(s) Then
            d(s) = arr(i, 2)
        Else
            If InStr("," & d(s) & ",", "," & arr(i, 2) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 2)
        End If
        s = s & vbTab & arr(i, 2)
        If Not d.Exists(s) Then
            d(s) = arr(i, 3)
        Else
            If InStr("," & d(s) & ",", "," & arr(i, 3) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 3)
        End If
        s = s & vbTab & arr(i, 3)
        If Not d.Exists(s) Then
            d(s) = arr(i, 4)
        Else
            If InStr("," & d(s) & ",", "," & arr(i, 4) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 4)
        End If
    Next
    ComboBox1.List = Filter(d.Keys, vbTab, False)
    MsgBox Timer - tt
End Sub

附件五——ComboBox控件四级联动.rar (17.89 KB, 下载次数: 2556)

2014-1-11 10:49 上传

点击文件名下载附件

本帖中使用了一些坛友的附件、代码，附件中都有原帖链接，在此向他们表示感谢。

永远不是明天

谢谢赵老师！赵老师也研究TreeView控件了呀，真是太好了！

windimi007

赵版辛苦了！

张雄友

太强大了，拿回公司试用并调整。{:soso_e179:}

lpzxhjp

赵老师的作品我只能说：一个字“好”！

excelsunshine

学习了，太好了。