分享一個關於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