如何在同一单元格内，实现多级下拉菜单

极速雪奔

各位大侠，如下图所示，如何做到无需手动输入文字，仅通过下拉菜单（两级）来达到图3的效果？

ovxyz

你可能发错板块了，函数公式无法实现这一功能。
但是可以实现多级菜单，多个单元格，多次选择的功能，
vba版块问问看吧。依我个人vba的功底也实现不了。可能再表单上可以间接实现。

quqiyuan

这种只能vba可以吧，把你的附件发上来，应该不难。

极速雪奔

quqiyuan 发表于 2024-9-12 14:33
这种只能vba可以吧，把你的附件发上来，应该不难。

难就难在在同一个单元格内完成，没有附件，用数据验证里面的序列只能实现一级，只能选省份，城市就需要手动输入

极速雪奔

ovxyz 发表于 2024-9-12 14:33
你可能发错板块了，函数公式无法实现这一功能。
但是可以实现多级菜单，多个单元格，多次选择的功能，
vb ...

实际上要的就是一个二级菜单的效果，感觉用公式也很难实现，因为要在同一单元格内完成

quqiyuan

极速雪奔 发表于 2024-9-12 14:43
难就难在在同一个单元格内完成，没有附件，用数据验证里面的序列只能实现一级，只能选省份，城市就需要手 ...

vba可以实现，供你参考。。。
写了两个事件，其实两个代码一样

quqiyuan

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    Application.EnableEvents = False
    If Len(Target) = 0 Or InStr(Target, "/") Then
        Set d = CreateObject("scripting.dictionary")
        arr = [j1].CurrentRegion
        For i = 2 To UBound(arr)
            d(arr(i, 1)) = arr(i, 1)
        Next
    Else
        Set d = CreateObject("scripting.dictionary")
        arr = [j1].CurrentRegion
        For i = 2 To UBound(arr)
            If arr(i, 1) = Target.Value Then d(arr(i, 2)) = Target.Value & "/" & arr(i, 2)
        Next
    End If
    Key = d.items
    ss = Join(Key, ",")
    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=ss
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
    Set d = Nothing
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    If Len(Target) = 0 Or InStr(Target, "/") Then
        Set d = CreateObject("scripting.dictionary")
        arr = [j1].CurrentRegion
        For i = 2 To UBound(arr)
            d(arr(i, 1)) = arr(i, 1)
        Next
    Else
        Set d = CreateObject("scripting.dictionary")
        arr = [j1].CurrentRegion
        For i = 2 To UBound(arr)
            If arr(i, 1) = Target.Value Then d(arr(i, 2)) = Target.Value & "/" & arr(i, 2)
        Next
    End If
    Key = d.items
    ss = Join(Key, ",")
    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=ss
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
    Set d = Nothing
End Sub