m级下拉菜单的制作

梦幻的流星

hqz883 发表于 2021-8-12 08:53
我有个表跟你这个非常类似，但是我刚开始接触VBA还不是很懂，我把你的代码粘贴过去也没改好。你能帮我看看s ...

这是筛选，和下拉菜单有关系吗？

hqz883

梦幻的流星 发表于 2021-8-12 09:13
这是筛选，和下拉菜单有关系吗？

呃，可以不下拉，但是也需要与基本数据的保持一致，保证数据有效性，所以我想到的就是下拉菜单了

blackttea1

非常不错，收藏了

vitrel

梦幻的流星 发表于 2021-7-31 11:56
根据网友建议的优化

楼主，您好！
首先，对于您学习VBA还未满一年就能写出这样的代码，
衷心地向您送上10086个赞！！

我真心认为您的代码很不错，也很实用，
但我发现了两个问题，现提出来好让大家讨论讨论：

1、假如A~E列已填满内容，此时更改B列的内容后，C列应清空且重设数据验证，而D~E列应清空且取消数据验证，这样设置才合理，其它如此类推；

2、以您的数据库为例，安徽省有一个合肥市，假如河南省也有一个同名的合肥市呢？那么第3列（区/县）在选择时就会乱套了。因此，每一列的选项不光要考虑其前一列的数据，还要考虑其前前一列、前前前一列……如此设置才合理。

以上是我的小小意见，如有不对，望谅！

CYZ凡星点点

感谢楼主分享

xsy我可以很好

vitrel 发表于 2021-9-27 16:25
楼主，您好！
首先，对于您学习VBA还未满一年就能写出这样的代码，
衷心地向您送上10086个赞！！

'代码来源：  [求助]大数据量，多级下拉菜单速度问题https://club.excelhome.net/thread-328961-1-1.html(出处: ExcelHome技术论坛)
'代码参考：  多级菜单（数据有效性）终极方案【VBA】https://club.excelhome.net/thread-1510919-1-1.html(出处: ExcelHome技术论坛)


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

    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim sj(), cTxt$, Arr(), sj2(1 To 7), nRow&, nL&

    If Target.Row = 1 Or Target.Column < 1 Or Target.Column > 7 Or Target.CountLarge > 1 Then Exit Sub
    nL = Target.Column

    sj = Range("a" & Target.Row).Resize(1, 7).Value

    With Sheets("地址")
        nRow = .Cells(1048576, 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) <> "" Then
                If cTxt <> "" Then
                    i = nRow
                    Exit For
                End If

                sj2(j) = Arr(i, j)

            End If
            If sj2(j) <> sj(1, j) Then Exit For
        Next
        If j = nL And Arr(i, nL) <> "" Then
            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

125675117

梦幻的流星 发表于 2021-7-31 11:56
根据网友建议的优化

给个建议，更换一级菜单选择后，后面几级自动清除内容