求解：多级下来菜单求助！

xho070323

Sub Worksheet_SelectionChange(ByVal Target As Range)
    n = Sheets("分值字典_获奖").Cells(Rows.Count, "a").End(xlUp).Row

    arr = Sheets("分值字典_获奖").Range("b2:f" & n)

    Set 区域 = Range("e6:i100000")
    On Error Resume Next
'    If InStr(Target.Address, ":") Then
'        Exit Sub '如果区域多选退出程序
'    End If

    If Not Intersect(Target, 区域) Is Nothing Then '如果有交集,那么执行
        '    If Intersect(Target, 区域) Is Nothing Then  '如果没有交集 那么执行
        With Target.Validation
            .Delete
            If Target.Column = 5 Then
                '选择区域的列号=5列,那么本级列号=1'用自定义函数  用字典设置数据有效性   提取字典下面的第一级菜单
                s = 多级下拉菜单(arr, 1)
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=s
            ElseIf Target.Column = 6 And Target.Offset(0, -1) <> "" Then
                '选择区域的列号=6列,那么本级列号=2'用自定义函数  用字典设置数据有效性   提取字典下面的第二级菜单
                s = 多级下拉菜单(arr, 2, Target.Offset(0, -2) & Target.Offset(0, -1), 1)
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=s
            ElseIf Target.Column = 7 And Target.Offset(0, -1) <> "" Then
                '选择区域的列号=7列,那么本级列号=3'用自定义函数  用字典设置数据有效性   提取字典下面的第三级菜单
                s = 多级下拉菜单(arr, 3, Target.Offset(0, -2) & Target.Offset(0, -1), 2)
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=s
            ElseIf Target.Column = 8 And Target.Offset(0, -1) <> "" Then
                '选择区域的列号=8列,那么本级列号=4'用自定义函数  用字典设置数据有效性   提取字典下面的第四级菜单
                s = 多级下拉菜单(arr, 4, Target.Offset(0, -2) & Target.Offset(0, -1), 3)
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=s
            ElseIf Target.Column = 9 And Target.Offset(0, -1) <> "" Then
                '选择区域的列号=9列,那么本级列号=5'用自定义函数  用字典设置数据有效性   提取字典下面的第五级菜单
                s = 多级下拉菜单(arr, 5, Target.Offset(0, -2) & Target.Offset(0, -1), 4)
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=s
            End If
        End With
    Else
        Exit Sub
    End If
End Sub
Function 多级下拉菜单(arr, 本级列号, Optional 上级 = "", Optional 上级列号 = 1)
    'arr  多级下来带单的  数据源 数组
    '本级列号    是多级菜单的数据源列号
    '上级   是作用选择区域的上一列中的内容,上一个单元格
    '上级列号  是作用选择区域的上一列
    '作用区域上级单元格的内容=数据源arr,本级列号的上一列
    Set dic = CreateObject("scripting.dictionary")
    If 上级 = "" Then
        For i = 1 To UBound(arr)
            dic(arr(i, 本级列号)) = ""  '利用item  的唯一性
        Next i
    Else
        For i = 1 To UBound(arr)
            If arr(i, 上级列号 - 1) & arr(i, 上级列号) = 上级 Then
                dic(arr(i, 本级列号)) = ""
            End If
        Next i
    End If
    多级下拉菜单 = IIf(dic.Count > 0, Join(dic.keys, ","), "")
End Function

xsy我可以很好

s = 多级下拉菜单(arr, 2, Target.Offset(0, -2) & Target.Offset(0, -1), 1)
红色部分删除就可以了

3190496160

Private Sub Worksheet_Change(ByVal T As Range)
If T.Row > 5 And T.Column > 4 And T.Column < 9 Then
    If T.Count > 1 Then End
    If T.Offset(, -1) = "" Then End
    Dim ar As Variant
    Dim i As Long, r As Long
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Sheets("分值字典_获奖")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        If r < 2 Then MsgBox "分值字典_获奖工作表为空！": End
        ar = .Range("a1:f" & r)
    End With
    lh = T.Column
    gs = T.Column - 4
    For i = 2 To UBound(ar)
        sl = 0
        For j = 5 To lh
            If ar(i, j - 3) = Cells(T.Row, j) Then
                sl = sl + 1
            End If
        Next j
        If sl = gs Then
            d(ar(i, T.Column - 2)) = ""
        End If
    Next i
    T.Offset(, 1).Select
    With T.Offset(, 1).Validation
        .Delete
        .Add 3, 1, 1, Join(d.keys, ",")
    End With
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row > 5 And T.Column = 5 Then
    If T.Count > 1 Then End
    Dim ar As Variant
    Dim i As Long, r As Long
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Sheets("分值字典_获奖")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        If r < 2 Then MsgBox "分值字典_获奖工作表为空！": End
        ar = .Range("a1:f" & r)
    End With
    For i = 2 To UBound(ar)
        If ar(i, 2) <> "" Then
            If Not d.exists(ar(i, 2)) Then Set d(ar(i, 2)) = CreateObject("scripting.dictionary")
            d(ar(i, 2))(ar(i, 3)) = ""
        End If
    Next i
    With T.Validation
        .Delete
        .Add 3, 1, 1, Join(d.keys, ",")
    End With
End If
End Sub

3190496160

五级下拉菜单代码求助.rar (75.31 KB, 下载次数: 8)

2024-11-14 09:06 上传

点击文件名下载附件

3190496160

必须首先填写D列，切记，切记

xho070323

xsy我可以很好 发表于 2024-11-14 08:15
s = 多级下拉菜单(arr, 2, Target.Offset(0, -2) & Target.Offset(0, -1), 1)
红色部分删除就可以了

大神：红色部分删除，第四级到第五级不得行！

xho070323

3190496160 发表于 2024-11-14 09:06

感谢，大神！很完美的解决问题。不过想建议一下：在设置变量尽量使用中文，这样方便读者学习和理解！还有有时候注解一下，说的不对的地方敬请谅解。再次感谢，万分感激！