数据有效性序列在EXCEL中的使用（二级下拉菜单 多级下拉菜单）

今天在群里被人问到多级下拉菜单，那么我就顺便发表出来，供大家学习。

在EXCEL中，下拉菜单除了控件外，简单的就是用数据有效性进行制作的。在新版EXCEL中，数据有效性在“数据选项卡”中。

上图中显示的结果，我们叫做一级菜单。制作方式如下：打开数据有效性--先把序列--输入需要的下拉菜单内容（注意用半角逗号隔开）--确定，最后就完成了这个菜单的制作。当然，要想在整列都使用的话，可以选择多行进行此操作。

当数据量大的时候，输入就不那么容易了，那么我们可以用单元格区域引用方式进行操作，如图：

下面，介绍一种简单的二级下拉菜单的制作方法。步骤：制作一级菜单-定位数据源-选择常量-以区域定义名称-选择首先-数据有效性-INDIRECT(一级菜单所在位置)。如以下动画：

但是，数据有效性是有一些缺陷的。比如容易被复制的内容粘贴之后，就无有效性了；上面的方法，如果数据源增加的话，又得重新做一次（虽然有OFFSET动态的方法，但此方法不易掌握,就不再介绍）；当层级多了的时候，用函数也不好解决。

下面，我提供一种VBA程序的解决方法。弹出式菜单。

首先，按ALT+F11打开VBE编辑器，并创建一个新模板，在模板里面输入以下内容：

Sub 菜单初始化(barName, arr, 宏名)

Dim mybar As CommandBar, myx, strF

'Dim f As CommandBarControl

Application.CommandBars(barName).Delete '重设菜单前删除原菜单

Dim dic, n, i, j

Set dic = CreateObject('scripting.dictionary')

Set mybar = Application.CommandBars.Add(Name:=barName, Position:=msoBarPopup) '创建弹出式菜单

'arr = Range('数据!a1').CurrentRegion.Value '定位数据区,源数据放入数组arr

n = UBound(arr, 2)

For i = 2 To UBound(arr)

Set myx = mybar

strF = ''

For j = 1 To n

strF = strF & '|' & arr(i, j)

If Not dic.Exists(strF) Then

If j = n Then

Set myx = myx.Controls.Add(Type:=msoControlButton)

myx.OnAction = 宏名 & '(' & i & ',' & n & ')'

Else

Set myx = myx.Controls.Add(Type:=msoControlPopup)

End If

myx.Caption = arr(i, j)

dic(strF) = 0

Else

Set myx = myx.Controls.Item(arr(i, j))

End If

Next

Next

End Sub

Sub 初始化执行程序()

Dim arr

arr = Range('拆分!a1').CurrentRegion.Value '定位数据区,源数据放入数组arr

Call 菜单初始化('myCell', arr, '输入')

End Sub

Sub 输入(i, m)

Dim arr

arr = Worksheets('拆分').Range('a' & i).Resize(1, m).Value

ActiveCell.EntireRow.Range('A1').Resize(1, m) = arr

End Sub

Public Sub SubPopBar(keys() As Variant)

'根据参数数组返回子菜单,并复制到单独的弹出菜单

Dim intI As Integer, subB

Dim mybar As CommandBar

Set subB = CommandBars('myCell')

On Error Resume Next

For intI = 0 To UBound(keys) '获得参数列表的子菜单

If keys(intI) <> '' Then

Set subB = subB.Controls(keys(intI))

Else

Application.CommandBars('myCell').ShowPopup '如果前面几列输入的数据为空则直接弹出顶级菜单

Exit Sub

End If

Next intI

Application.CommandBars('myCellx').Delete '重设菜单前删除原菜单

Set mybar = Application.CommandBars.Add(Name:='myCellx', Position:=msoBarPopup) '创建弹出式菜单

For intI = 1 To subB.Controls.Count

subB.Controls(intI).Copy Bar:=mybar '从顶级菜单中摘出需要的子菜单

Next

Set subB = Nothing

Set mybar = Nothing

Application.CommandBars('myCellx').ShowPopup

End Sub

接下来，在ThisWorkbook代码框中，录入以下事件：

Private Sub Workbook_Open()

Call 初始化执行程序

End Sub

同时，在需要显示的工作表代码框中，录入以下事件：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim a(), i '根据选择项摘取需要的子菜单

If Target.Count = 1 And Target.Row > 1 Then

If Target.Column = 1 Then

Application.CommandBars('myCell').ShowPopup '若在第一级则直接使用全部菜单

ElseIf Target.Column <= sheets('拆分').usedrange.columns.count="">

ReDim a(0 To Target.Column - 2)

For i = 1 To Target.Column - 1

If Cells(Target.Row, i) <> '' Then

a(i - 1) = Cells(Target.Row, i)

Else

i = Target.Column

End If

Next

Call SubPopBar(a) '若在第N级则弹出N级子菜单

End If

End If

End Sub

这下，比较高大上的多级下拉菜单就制作完毕，以下是效果图：

以下是数据源图及步骤图: