右键树型菜单

zhaogang1960

三级菜单参数不对，应该msoControlButton
临时文件.rar (45.14 KB, 下载次数: 59)

2013-11-24 18:57 上传

点击文件名下载附件

笑着...两年过去

zhaogang1960 发表于 2013-11-24 18:58
三级菜单参数不对，应该msoControlButton

不知什么原因，每次都报错误5，请求再次指教

zhaogang1960

笑着...两年过去 发表于 2013-11-24 19:07
不知什么原因，每次都报错误5，请求再次指教

我在Excel2003测试的，2007中删除右键菜单原项目不兼容，就不删除它们了，在右键菜单原项目下端添加新菜单：
临时文件.rar (44.6 KB, 下载次数: 50)

2013-11-24 19:33 上传

点击文件名下载附件

zhaogang1960

帅啊，要是单击末项，末项就显示在此单元格

1. Sub CreatMe() '生成右键菜单
   
2.     Dim d As Object, ds As Object, i&, j&, k, k2, k3, l&, arr
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
   
8.         If Len(arr(i, 2)) Then
   
9.             d(arr(i, 1))(arr(i, 2)) = ""
   
10.             If Not ds.Exists(arr(i, 1) & arr(i, 2)) Then Set ds(arr(i, 1) & arr(i, 2)) = CreateObject("scripting.dictionary")
    
11.             If Len(arr(i, 3)) Then ds(arr(i, 1) & arr(i, 2))(arr(i, 3)) = ""
    
12.         End If
    
13.     Next
    
14.     k = d.keys
    
15.     With Application.CommandBars("cell")
    
16.         .Reset '重置右键菜单,以免因多次运行重复添加
    
17.         For i = 0 To UBound(k)
    
18.             With .Controls.Add(Type:=msoControlPopup)
    
19.                 .Caption = k(i)
    
20.                 .OnAction = ""
    
21.                 .BeginGroup = True '分组显示
    
22.                 k2 = d(k(i)).keys
    
23.                 For j = 0 To UBound(k2)
    
24.                     With .Controls.Add(Type:=msoControlPopup)
    
25.                         .Caption = k2(j)
    
26.                         .OnAction = ""
    
27.                         k3 = ds(k(i) & k2(j)).keys
    
28.                         For l = 0 To UBound(k3)
    
29.                             With .Controls.Add(Type:=msoControlButton)
    
30.                                 .Caption = k3(l)
    
31.                                 .OnAction = "'显示在活动单元格 """ & k3(l) & """'"
    
32.                             End With
    
33.                         Next
    
34.                     End With
    
35.                 Next
    
36.             End With
    
37.         Next
    
38.     End With
    
39.       
    
40. End Sub
    
41. 
    
42. Sub 显示在活动单元格(s$)
    
43.     ActiveCell.Value = s
    
44. End Sub
    

复制代码

zhaogang1960

原来选择改为右键单击：

1. Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   
2.     If Target.Column = 6 Then
   
3.         Call CreatMe
   
4.     Else
   
5.         Call DeleteMycell
   
6.     End If
   
7. End Sub

复制代码

zhaogang1960

请看附件
临时文件.rar (46.61 KB, 下载次数: 73)

2013-11-24 20:02 上传

点击文件名下载附件

苍海拾贝

学习了版主的代码，受益匪浅，谢谢！
一点改进：增加了对只有一级分类或者二级分类的项目输入的支持，请测试

笑着...两年过去

苍海拾贝 发表于 2013-11-25 08:40
学习了版主的代码，受益匪浅，谢谢！
一点改进：增加了对只有一级分类或者二级分类的项目输入的支持，请测 ...

如果不要其他选项，只要sheet1里的内容，如何再做修改咧？

jsxjd

笑着...两年过去 发表于 2013-11-25 09:54
如果不要其他选项，只要sheet1里的内容，如何再做修改咧？

把原来的菜单都删除吗？

    k = d.keys
    For Each x In CommandBars("cell").Controls
        x.Delete
    Next
    With Application.CommandBars("cell")
        '.Reset '重置右键菜单,以免因多次运行重复添加

苍海拾贝

笑着...两年过去 发表于 2013-11-25 09:54
如果不要其他选项，只要sheet1里的内容，如何再做修改咧？

有误，删除