右键树型菜单

笑着...两年过去

                  初学VBA，请求各位帮忙制作一个右键菜单
临时文件.rar (34.35 KB, 下载次数: 53)

2013-11-24 16:44 上传

点击文件名下载附件

zhaogang1960

短信收到，建议使用窗体，即单击F列显示窗体

笑着...两年过去

zhaogang1960 发表于 2013-11-24 16:51
短信收到，建议使用窗体，即单击F列显示窗体

具体该如何做了，还请赵版指教一二

安然祥和

我也等看老师们的答案，很遗憾，我对VBA还不入门。…………

zhaogang1960

1. Sub DeleteMycell() '还原右键菜单
   
2.     Application.CommandBars("cell").Reset
   
3. End Sub
   
4. 
   
5. Sub CreatMe() '生成右键菜单
   
6.     Dim d As Object, ds As Object, i&, j&, k, k2, k3, l&, arr
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set ds = CreateObject("scripting.dictionary")
   
9.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
10.     For i = 2 To UBound(arr)
    
11.         If Not d.Exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.         If Len(arr(i, 2)) Then
    
13.             d(arr(i, 1))(arr(i, 2)) = ""
    
14.             If Not ds.Exists(arr(i, 1) & arr(i, 2)) Then Set ds(arr(i, 1) & arr(i, 2)) = CreateObject("scripting.dictionary")
    
15.             If Len(arr(i, 3)) Then ds(arr(i, 1) & arr(i, 2))(arr(i, 3)) = ""
    
16.         End If
    
17.     Next
    
18.     k = d.keys
    
19.     With Application.CommandBars("cell")
    
20.         .Reset '重置右键菜单,以免因多次运行重复添加
    
21.         .Controls("删除(&D)...").Delete '
    
22.         .Controls("复制(&C)").Delete '
    
23.         .Controls("粘贴(&P)").Delete '
    
24.         .Controls("剪切(&T)").Delete '删除右键菜单中的剪切菜单
    
25.         .Controls("清除内容(&N)").Delete '
    
26.         .Controls("从下拉列表中选择(&K)...").Delete '
    
27.         .Controls("选择性粘贴(&S)...").Delete '
    
28.         .Controls("添加监视点(&W)").Delete '
    
29.         .Controls("创建列表(&C)...").Delete '
    
30.         .Controls("超链接(&H)...").Delete '
    
31.         .Controls("查阅(&L)...").Delete '
    
32.         For i = 0 To UBound(k)
    
33.             With .Controls.Add(Type:=msoControlPopup)
    
34.                 .Caption = k(i)
    
35.                 .OnAction = ""
    
36.                 .BeginGroup = True '分组显示
    
37.                 k2 = d(k(i)).keys
    
38.                 For j = 0 To UBound(k2)
    
39.                     With .Controls.Add(Type:=msoControlPopup)
    
40.                         .Caption = k2(j)
    
41.                         .OnAction = ""
    
42.                         k3 = ds(k(i) & k2(j)).keys
    
43.                         For l = 0 To UBound(k3)
    
44.                             With .Controls.Add(Type:=msoControlPopup)
    
45.                                 .Caption = k3(l)
    
46.                                 .OnAction = ""
    
47.                             End With
    
48.                         Next
    
49.                     End With
    
50.                 Next
    
51.             End With
    
52.         Next
    
53.     End With
    
54.       
    
55. End Sub
    

复制代码

zhaogang1960

Private Sub Workbook_Deactivate() 'ThisWorkbook防止影响其他工作簿
    Call DeleteMycell
End Sub
Private Sub Worksheet_Deactivate() '防止影响其他工作表
    Call DeleteMycell
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 6 Then
        Call CreatMe
    Else
        Call DeleteMycell
    End If
End Sub

zhaogang1960

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

2013-11-24 18:16 上传

点击文件名下载附件

笑着...两年过去

zhaogang1960 发表于 2013-11-24 18:16
请看附件

欧巴，好像那里不对，您再给看看呗

zhaogang1960

笑着...两年过去 发表于 2013-11-24 18:52
欧巴，好像那里不对，您再给看看呗

哪里不对，请明示

zhaogang1960

请看演示