二级代码修改为三级

①然如故

请老师赐教，表中的二级代码如何改为三级，谢谢！
三级菜单.rar (30.88 KB, 下载次数: 16)

2018-3-29 13:31 上传

点击文件名下载附件

wdx223

1. Private Sub Worksheet_SelectionChange(ByVal target As Range)
   
2.     If target.Address <> "$B$2:$G$2" And target.Address <> "$B$3:$G$3" And target.Address <> "$B$4:$G$4" Then Exit Sub
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("数据源").[a1].CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 2)
   
7.         If Not d.exists(x) Then
   
8.             Set d(x) = CreateObject("Scripting.Dictionary")
   
9.             d(x)(arr(i, 3) & "") = arr(i, 4)
   
10.         ElseIf InStr("," & d(x)(arr(i, 3) & "") & ",", "," & arr(i, 4) & ",") = 0 Then
    
11.             d(x)(arr(i, 3) & "") = d(x)(arr(i, 3) & "") & "," & arr(i, 4)
    
12.         End If
    
13.     Next i
    
14.     With target.Validation
    
15.         .Delete
    
16.         Select Case target.Address
    
17.             Case "$B$2:$G$2"
    
18.                 .Add xlValidateList, , , Join(d.keys, ",")
    
19.                 [b3:b4] = ""
    
20.             Case "$B$3:$G$3"
    
21.                 .Add xlValidateList, , , Join(d([B2].Value).keys, ",")
    
22.                 [b4] = ""
    
23.             Case "$B$4:$G$4"
    
24.                 .Add xlValidateList, , , d([B2].Value)([B3].Value)
    
25.         End Select
    
26.     End With
    
27.     On Error Resume Next
    
28.     SendKeys "%{down}"  '发送到下级
    
29.      'http://www.excelpx.com/thread-375699-3-1.html
    
30. End Sub

复制代码