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

fuexcel77

留下脚印，备用

zminzhu

不错，太强大了

和乐隐士

谢谢老师分享！！！

独饮雨醉

收藏学习，感谢楼主分享成果！

eess890528

山菊花 发表于 2019-12-4 14:30
数据有效性列从D列开始，那么，下一行：
   If Target.Row = 1 Or Target.Column > 4 Or Target.CountLa ...

版主， 您好！

我按照您的上述提示，更改成我需要的四级数据有效性，但是提示错误（红色部分）（有时候有报错，有时候不报错），能请您帮忙看下是什么原因吗？感谢！

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim nL%
    nL = Target.Column
    If Target.Row < 7 Or Target.Row > 26 Or nL < 2 Or nL > 5 Or Target.CountLarge > 1 Then Exit Sub
    Application.EnableEvents = False
    Target.Offset(0, 1).Resize(1, 6 - nL).ClearContents
    Application.EnableEvents = True
End Sub

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 < 7 Or Target.Row > 26 Or Target.Column < 2 Or Target.Column > 5 Or Target.CountLarge > 1 Then Exit Sub
    nL = Target.Column - 1
    sj = Range("b" & Target.Row).Resize(1, 3).Value
    With Sheets("基础信息")
        nRow = .Cells(5000, 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

eess890528

山菊花 发表于 2019-12-4 14:30
数据有效性列从D列开始，那么，下一行：
   If Target.Row = 1 Or Target.Column > 4 Or Target.CountLa ...

版主，您好！

我按照您的上贴提示更改的四级数据有效性，能否请您帮忙看下附件中的报错？谢谢！

rolanchen

天呐 我这两天一直在研究这个问题，甚至还做了个数组剔重的自定义公式，搞得很麻烦，没想到一上来就看有终极方案，太牛了！

山菊花

eess890528 发表于 2021-9-29 14:32
版主，您好！

我按照您的上贴提示更改的四级数据有效性，能否请您帮忙看下附件中的报错？谢谢！

没看到报错。

naroto

IVYQQQQQ 发表于 2019-12-3 09:48
在版主面前班门弄斧一下，提个小建议，我现在也一直用多级菜单的，我的做法多了如下内容：
1、在输入当 ...

这个不错，学习了

aecn

好东西，学习一下