右键树型菜单

zhaogang1960

zjisy 发表于 2013-12-5 13:37
赵老师强大，请问赵老师，临时文件(提前设置字典)四级分类显示最后两个单元格怎么做到呢？就是选到最后，显 ...

1.     Dim d As Object, i&, j&, k, k2, t2, a3, l&, arr, s$
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         s = arr(i, 1)
   
6.         If InStr(d(s) & ",", "," & arr(i, 2) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 2) '字典键值是一级菜单,字典条目是二级菜单
   
7.         If Len(arr(i, 2)) Then
   
8.             s = s & vbTab & arr(i, 2)
   
9.             If InStr(d(s) & ",", "," & arr(i, 3) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 3) '字典条目是三级菜单
   
10.             If Len(arr(i, 3)) Then
    
11.                 s = s & vbTab & arr(i, 3)
    
12.                 If InStr(d(s) & ",", "," & arr(i, 4) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 4) '字典条目是四级菜单
    
13.             End If
    
14.         End If
    
15.     Next
    
16.     k = Filter(d.Keys, vbTab, False) '一级分类，不含vbTab
    
17.     On Error Resume Next
    
18.     Application.CommandBars("树型菜单").Delete '删除可能存在的"树型菜单"菜单
    
19.     With Application.CommandBars.Add("树型菜单", msoBarPopup)
    
20.         For i = 0 To UBound(k)
    
21.             t2 = d(k(i)) '二级分类，每个二级分类用逗号隔开
    
22.             a2 = Split(t2, ",") '二级分类数组
    
23.             With .Controls.Add(Type:=IIf(Len(t2) > UBound(a2), msoControlPopup, msoControlButton)) '二级分类t2都是逗号，即没有实际项目，则msoControlButton
    
24.                 .Caption = k(i)
    
25.                 .OnAction = IIf(Len(t2) > UBound(a2), "", "'显示在活动单元格 """ & .Caption & """'")
    
26.                 .BeginGroup = True '分组显示
    
27.                 For j = 1 To UBound(a2) '逐个二级分类
    
28.                     If Len(a2(j)) Then '如果二级分类不为空
    
29.                         t3 = d(k(i) & vbTab & a2(j)) '三级分类，每个三级分类用逗号隔开
    
30.                         a3 = Split(t3, ",") '三级分类数组
    
31.                         With .Controls.Add(Type:=IIf(Len(t3) > UBound(a3), msoControlPopup, msoControlButton))
    
32.                             .Caption = a2(j)
    
33.                             .OnAction = IIf(Len(t3) > UBound(a3), "", "'显示在活动单元格 """ & .Caption & """'")
    
34.                             For l = 1 To UBound(a3)
    
35.                                 If Len(a3(l)) Then
    
36.                                     t4 = d(k(i) & vbTab & a2(j) & vbTab & a3(l)) '四级分类，每个四级分类用逗号隔开
    
37.                                     a4 = Split(t4, ",") '四级分类数组
    
38.                                     With .Controls.Add(Type:=IIf(Len(t4) > UBound(a4), msoControlPopup, msoControlButton))
    
39.                                         .Caption = a3(l)
    
40.                                         .OnAction = IIf(Len(t4) > UBound(a4), "", "'显示在活动单元格 """ & .Caption & """'")
    
41.                                         For v = 1 To UBound(a4)
    
42.                                             If Len(a4(v)) Then
    
43.                                                 With .Controls.Add(Type:=msoControlButton) '创建四级菜单
    
44.                                                     .Caption = a4(v)
    
45.                                                     .OnAction = "'显示在活动单元格 """ & a3(l) & Chr(10) & .Caption & """'" '四级菜单显示出三级和四级单元格内的内容，用行号符隔开
    
46.                                                 End With
    
47.                                             End If
    
48.                                         Next
    
49.                                     End With
    
50.                                 End If
    
51.                             Next
    
52.                         End With
    
53.                     End If
    
54.                 Next
    
55.             End With
    
56.         Next
    
57.     End With
    
58. End Sub

复制代码

zhaogang1960

请看附件
临时文件(提前设置字典)四级分类显示最后两个单元格怎么做到呢.rar (50.03 KB, 下载次数: 126)

2013-12-5 16:47 上传

点击文件名下载附件

zhaogang1960

为了更方便扩展菜单层数，把字典设置改为循环：

1. 
   
2. Sub CreatMe() '一个字典生成左键四级树型菜单
   
3.     Dim d As Object, i&, j&, k, k2, t2, a3, l&, arr, s$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         If InStr(d(s) & ",", "," & arr(i, 2) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 2) '字典键值是一级菜单,字典条目是二级菜单
   
9.         For j = 2 To 3 '从第二级到倒数第二级菜单
   
10.             If Len(arr(i, j)) = 0 Then Exit For '从第二级到倒数第二级如果出现空单元格，则退出j循环
    
11.             s = s & vbTab & arr(i, j)
    
12.             If InStr(d(s) & ",", "," & arr(i, j) & ",") = 0 Then d(s) = d(s) & "," & arr(i, j + 1) '字典条目是j+1级菜单
    
13.         Next
    
14. '        If Len(arr(i, 2)) Then
    
15. '            s = s & vbTab & arr(i, 2)
    
16. '            If InStr(d(s) & ",", "," & arr(i, 3) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 3) '字典条目是三级菜单
    
17. '            If Len(arr(i, 3)) Then
    
18. '                s = s & vbTab & arr(i, 3)
    
19. '                If InStr(d(s) & ",", "," & arr(i, 4) & ",") = 0 Then d(s) = d(s) & "," & arr(i, 4) '字典条目是四级菜单
    
20. '            End If
    
21. '        End If
    
22.     Next
    
23.     k = Filter(d.Keys, vbTab, False) '一级分类，不含vbTab
    
24.     On Error Resume Next
    
25.     Application.CommandBars("树型菜单").Delete '删除可能存在的"树型菜单"菜单
    
26.     With Application.CommandBars.Add("树型菜单", msoBarPopup)
    
27.         For i = 0 To UBound(k)
    
28.             t2 = d(k(i)) '二级分类，每个二级分类用逗号隔开
    
29.             a2 = Split(t2, ",") '二级分类数组
    
30.             With .Controls.Add(Type:=IIf(Len(t2) > UBound(a2), msoControlPopup, msoControlButton)) '二级分类t2都是逗号，即没有实际项目，则msoControlButton
    
31.                 .Caption = k(i)
    
32.                 .OnAction = IIf(Len(t2) > UBound(a2), "", "'显示在活动单元格 """ & .Caption & """'")
    
33.                 .BeginGroup = True '分组显示
    
34.                 For j = 1 To UBound(a2) '逐个二级分类
    
35.                     If Len(a2(j)) Then '如果二级分类不为空
    
36.                         t3 = d(k(i) & vbTab & a2(j)) '三级分类，每个三级分类用逗号隔开
    
37.                         a3 = Split(t3, ",") '三级分类数组
    
38.                         With .Controls.Add(Type:=IIf(Len(t3) > UBound(a3), msoControlPopup, msoControlButton))
    
39.                             .Caption = a2(j)
    
40.                             .OnAction = IIf(Len(t3) > UBound(a3), "", "'显示在活动单元格 """ & .Caption & """'")
    
41.                             For l = 1 To UBound(a3)
    
42.                                 If Len(a3(l)) Then
    
43.                                     t4 = d(k(i) & vbTab & a2(j) & vbTab & a3(l)) '四级分类，每个四级分类用逗号隔开
    
44.                                     a4 = Split(t4, ",") '四级分类数组
    
45.                                     With .Controls.Add(Type:=IIf(Len(t4) > UBound(a4), msoControlPopup, msoControlButton))
    
46.                                         .Caption = a3(l)
    
47.                                         .OnAction = IIf(Len(t4) > UBound(a4), "", "'显示在活动单元格 """ & .Caption & """'")
    
48.                                         For v = 1 To UBound(a4)
    
49.                                             If Len(a4(v)) Then
    
50.                                                 With .Controls.Add(Type:=msoControlButton) '创建四级菜单
    
51.                                                     .Caption = a4(v)
    
52.                                                     .OnAction = "'显示在活动单元格 """ & a3(l) & Chr(10) & .Caption & """'" '四级菜单显示出三级和四级单元格内的内容，用行号符隔开
    
53.                                                 End With
    
54.                                             End If
    
55.                                         Next
    
56.                                     End With
    
57.                                 End If
    
58.                             Next
    
59.                         End With
    
60.                     End If
    
61.                 Next
    
62.             End With
    
63.         Next
    
64.     End With
    
65. End Sub

复制代码

zhaogang1960

请看附件
临时文件(提前设置字典)四级分类显示最后两个单元格怎么做到呢.rar (51.01 KB, 下载次数: 165)

2013-12-5 18:48 上传

点击文件名下载附件

yq7219

还得认真学习一下，还要请教赵老师，如何更改可以选择每一级菜单？如果是最后一级菜单，如何将不是KEY的数据提取出来，填入对应单元格，详见附件

wayne0719

欧巴，为嘛我运行出错呢。请看附件截图

忆LE

请教赵老师，如何只显示第四级菜单。
另外，44楼的 效果， 第三级菜单如果有相同项，菜单会重复显示。

风霜

看不懂呀！

kane027

zhaogang1960 发表于 2013-12-5 18:48
请看附件

赵版，您能否抽空帮我看看这个贴子？万分感谢！
http://club.excelhome.net/forum. ... =1200978&extra=

吾股丰登

赵刚老师技术太牛逼了   佩服佩服