多级菜单（数据有效性）终极方案【VBA】

山菊花 · 发表于 2019-12-2 22:43

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sj(), nL%, cTxt$, nRow%, Arr(), ds As Object
Set ds = CreateObject("Scripting.Dictionary")
If Target.Row = 1 Or Target.Column > 4 Or Target.CountLarge > 1 Then Exit Sub
nL = Target.Column
sj = Range("a" & Target.Row).Resize(1, 3).Value
With Sheets("基础")
nRow = .Cells(999, nL).End(xlUp).Row
Arr = .Range("a1").Resize(nRow, nL).Value
End With
For i = 2 To nRow
For j = 1 To nL - 1
If Arr(i, j) <> sj(1, j) Then Exit For
Next
If j = nL And Not ds.exists(Arr(i, nL)) Then
ds(Arr(i, nL)) = ""
cTxt = cTxt & "," & Arr(i, nL)
End If
Next
With Target.Validation
.Delete
If cTxt <> "" Then .Add 3, 1, 1, Mid(cTxt, 2)
End With
End Sub

复制代码

四级菜单1.rar (15.83 KB, 下载次数: 1153)

四级菜单2.rar (13.23 KB, 下载次数: 902)

四级菜单3.rar (46.37 KB, 下载次数: 1329)

四级菜单4.rar (19.07 KB, 下载次数: 830)

四级菜单（窗体列表框）.rar (19.75 KB, 下载次数: 987)

大数据提速方案：

五级区域下拉菜单.rar (567.46 KB, 下载次数: 1042)

FOB_FN_L · 发表于 2019-12-2 23:09

不错，学习，收下了~

ggmmlol · 发表于 2019-12-2 23:34

坐沙发慢慢学

feiyang8878 · 发表于 2019-12-2 23:35

感谢分享

YZC51 · 发表于 2019-12-3 00:09

谢谢老师分享！！！

changhong8 · 发表于 2019-12-3 06:05

vba多级有效性方案
1、用事件:使用人电脑需能运行vba:
2、批量创建名称，一环一环串起来,可以自己做好发出去让其他人填写。

山菊花 · 发表于 2019-12-3 07:25

IVYQQQQQ · 发表于 2019-12-3 09:48

山菊花发表于 2019-12-3 07:25
参考实例：
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1510882&pid=10166159

在版主面前班门弄斧一下，提个小建议，我现在也一直用多级菜单的，我的做法多了如下内容：
1、在输入当前级时，提示要清除后面所以级的内容，因为前的级变化了，后面的级也会变化，不清除重选，原来的数据是不会变化的；
2、点到当前级时，用Application.SendKeys "%{down}"自动下拉，不用再点选箭头。