ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 97|回复: 6

求解:多级下来菜单求助!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-11-13 22:28 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
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


在这个地方都无法向下运行!

在这个地方都无法向下运行!

五级下拉菜单代码求助.zip

94.87 KB, 下载次数: 8

TA的精华主题

TA的得分主题

发表于 2024-11-14 08:15 | 显示全部楼层
s = 多级下拉菜单(arr, 2, Target.Offset(0, -2) & Target.Offset(0, -1), 1)
红色部分删除就可以了

TA的精华主题

TA的得分主题

发表于 2024-11-14 09:05 | 显示全部楼层
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

TA的精华主题

TA的得分主题

发表于 2024-11-14 09:06 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-11-14 09:07 | 显示全部楼层
必须首先填写D列,切记,切记

TA的精华主题

TA的得分主题

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

大神:红色部分删除,第四级到第五级不得行!

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-11-14 21:04 | 显示全部楼层

感谢,大神!很完美的解决问题。不过想建议一下:在设置变量尽量使用中文,这样方便读者学习和理解!还有有时候注解一下,说的不对的地方敬请谅解。再次感谢,万分感激!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-15 06:47 , Processed in 0.042366 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表