附件五

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

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

一、三级联动列表框

原代码如下(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

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连接起来添加到字典键值，把三级项目添加到字典条目，和原条目用逗号隔开

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

MsgBox Timer - tt

本帖最后由 zhaogang1960 于 2013-12-6 01:47 编辑

二、用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

本帖最后由 zhaogang1960 于 2013-12-6 00:20 编辑

三、左键三级菜单，新加一个附件《四级菜单显示最后两级到单元格》
字典嵌套代码如下：
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

本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。