access vba 批量设置下拉菜单 vba下拉菜单快速选择

分享一个关于Excel下拉框多选，并且支持搜索的案例
点击下载示例Excel文件（内含代码） 相信接触过Excel的同学都知道，Excel的下拉框本身不支持多选，只能单选，但是如果业务一定要你能够支持多选怎么办呢？于是便要从Excel的宏说起了（有关于Excel的宏的概念请左转百度搜索，这里只讲如果实现）

效果预览

输入筛选词后：

第一步、新建xlsx工作表，打开后另存为启用宏的工作簿，即xlm格式

第二步、打开另存的xlm文件，选择开发工具，插入两个控件（文本框TextBox和列表框ListBox）

第三步、点击开发工具-查看代码，选择sheet1并双击，出现代码输入框，粘贴下面代码

'功能: 支持搜索的多选数据录入设计
'未经许可，请勿用作商业用途
'------------------------------------------------


'----参数配置-----
'-数据源区域地址
Const dataAddress As String = "A1:A300"
'-多选框生效列
Const lsPos As Long = 2
'-录入内容的分隔符
Const SepChar As String = ","
'-数据录入的表名称(sheetName)
Const ShtName As String = "Sheet2"

'功能：输入框录入
'开发日期：20220518
'-------------------------------------
Private Sub TextBox1_Change()
    Dim cellValue As String
    cellValue = ActiveCell.Cells.Value
    With Sheet1.ListBox1
        .Clear
        If .ListCount = 0 Then
            Dim rng As Range
            For Each rng In Sheets(ShtName).Range(dataAddress)
                If rng <> "" And InStr(rng, TextBox1.Value) Then
                    .AddItem (rng)
                End If
            Next
        End If
    End With
    If cellValue <> "" Then
        Call checkCell(cellValue)
    End If
    ActiveCell.Value = cellValue
End Sub


'功能：列表框录入
'开发日期：20210511
'-------------------------------------
Private Sub ListBox1_Change()
    Dim i As Long
    Dim Selected As String
    Dim item As String
    Selected = ActiveCell.Cells.Value
    With Me.ListBox1
        For i = 0 To .ListCount - 1
            item = .List(i)
            '如果选择项不在Selected中，但是选了，则添加进去
            If .Selected(i) And InStr(Selected, item) = 0 Then
                Selected = Selected & SepChar & item
            End If
            '如果选择项在Selected中，但是没选，则删除
            If Not .Selected(i) And InStr(Selected, item) > 0 Then
                Selected = Replace(Selected, SepChar & item, "")
                Selected = Replace(Selected, item & SepChar, "")
                If InStr(Selected, SepChar) = 0 Then
                    Selected = Replace(Selected, item, "")
                End If
            End If
        Next
    End With
    If Left(Selected, 1) = SepChar Then
        Selected = Mid(Selected, 2)
    End If
    ActiveCell.Value = Selected
End Sub


'功能：列表框显示的条件和位置
'开发日期：20210511
'-------------------------------------
Private Sub Worksheet_SelectionChange(ByVal target As Range)
    TextBox1.Value = ""
    '选择多个单元格不显示，退出过程
    If target.CountLarge > 1 Then
        Me.ListBox1.Visible = False: End
    End If
    '如果是指定列，
    If target.Column = lsPos And target.Row > 1 Then
        '初始化ls
        Call lsConfig
        '检查单元格内容
        Call checkCell(target.Value)
    Else
        Me.ListBox1.Visible = False
        Me.TextBox1.Visible = False
    End If
End Sub


'功能：检测单元格内容，同步Listbox选择
'开发日期：20210511
'------------------------------------------
Function checkCell(rng As String)
    Dim eve
    dataarr = Application.Transpose( _
        Sheets(ShtName).Range(dataAddress).Value)
    If Len(rng) > 0 Then
        arr = Split(rng, SepChar)
        For Each eve In arr
            If UBound(Filter(dataarr, eve)) > -1 Then
                With Me.ListBox1
                    For i = 0 To .ListCount - 1
                    If .List(i) = eve Then
                        .Selected(i) = True
                    End If
                    Next
                End With
            End If
        Next
    Else
        With Me.ListBox1
            For i = 0 To .ListCount - 1
                .Selected(i) = False
            Next
        End With
    End If
End Function


'功能：列表框初始设置
'开发日期：20210511
'------------------------------------------
Sub lsConfig()
    Dim target As String
    target = ActiveCell.Cells.Value
    With Sheet1.ListBox1
        .Clear
        Dim rng As Range
        For Each rng In Sheets(ShtName).Range(dataAddress)
            If rng <> "" Then
                .AddItem (rng)
            End If
        Next
    End With
    With Sheet1.ListBox1
        .Left = ActiveCell.Left + ActiveCell.Width
        .Top = ActiveCell.Top
        '使用配置列宽，如果隐藏使用活动单元格*1.8列宽
        dtWidth = Sheets(ShtName).Range(dataAddress) _
        .EntireColumn.Width
        If dtWidth > 0 Then
            .Width = dtWidth
        Else
            .Width = ActiveCell.Width * 1.8
        End If
        '使用数据源行高+5(自定义函数获取),更加智能
        .Height = getHeight()
        .MultiSelect = fmMultiSelectMulti
        .ListStyle = fmListStyleOption
        .Visible = True
    End With
    With Sheet1.TextBox1
        .Left = ActiveCell.Left + ActiveCell.Width
        .Top = ActiveCell.Top - .Height + 2
        .Width = Sheet1.ListBox1.Width
        .Visible = True
        .Height = 25
    End With
End Sub


'获取data数据行高
Function getHeight()
    Dim rng As Range, hg As Single
    For Each rng In Sheets(ShtName).Range(dataAddress)
        If rng <> "" Then
            hg = hg + rng.Height
        End If
    Next
    getHeight = Application.Min(hg, 280)
End Function