Excel VBA需求：为库存及借贷账本实现可搜索下拉列表

我在处理库存及DR/CR（借贷）账本时，每次都得手动输入客户、供应商或项目名称，很容易犯拼写错误。想做一个可搜索的下拉列表，通过搜索选择对应名称。试了论坛里的一段setupDV代码，但生成的下拉列表不支持搜索，只会显示完整列表，代码如下：

Sub setupDV()
Dim rSource As Range, rDV As Range, r  As Range, csString As String
Dim c As Collection

    Set rSource = Sheets("Sheet2").Range("B1:B1000")
    Set rDV = Sheets("Sheet1").Range("C5")
    Set c = New Collection
    csString = ""
    On Error Resume Next
    For Each r In rSource
        v = r.Value
        If v <> "" Then
            c.Add v, CStr(v)
            If Err.Number = 0 Then
                If csString = "" Then
                    csString = v
                Else
                    csString = csString & "," & v
                End If
            Else
                Err.Number = 0
            End If
        End If
    Next r
    On Error GoTo 0
    
    'MsgBox csString
    
    With rDV.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=csString
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = False
    End With

End Sub

原代码的问题在于：它用Excel原生的数据验证生成普通下拉列表，这种下拉本身不支持搜索功能。下面提供两种可行的解决方案：

方案1：ActiveX组合框实现实时搜索下拉 #

这种方式体验更流畅，支持实时输入过滤：

1. 打开「开发工具」选项卡，插入「ActiveX控件」里的组合框（ComboBox）
2. 调整组合框大小，完全覆盖目标单元格（Sheet1的C5）
3. 右键组合框，选择「查看代码」，粘贴以下代码：

Private Sub ComboBox1_Change()
    Dim wsSource As Worksheet
    Dim rSource As Range
    Dim i As Integer
    
    Set wsSource = ThisWorkbook.Sheets("Sheet2")
    Set rSource = wsSource.Range("B1:B1000")
    
    ComboBox1.Clear ' 清空现有列表
    
    ' 遍历数据源，模糊匹配输入内容（不区分大小写）
    For i = 1 To rSource.Rows.Count
        If rSource.Cells(i, 1).Value <> "" Then
            If UCase(rSource.Cells(i, 1).Value) Like "*" & UCase(ComboBox1.Text) & "*" Then
                ComboBox1.AddItem rSource.Cells(i, 1).Value
            End If
        End If
    Next i
    
    ' 有匹配项则展开下拉列表
    If ComboBox1.ListCount > 0 Then
        ComboBox1.DropDown
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 点击C5时显示组合框并获取焦点
    If Target.Address = "$C$5" Then
        ComboBox1.Visible = True
        ComboBox1.SetFocus
    Else
        ComboBox1.Visible = False
        ' 将选中值写入单元格
        If ComboBox1.Value <> "" Then
            Range("C5").Value = ComboBox1.Value
        End If
    End If
End Sub

注意事项 #

• 把代码中的ComboBox1改成你插入的组合框实际名称（可在开发工具的「属性」窗口修改）
• 数据源范围B1:B1000可根据实际数据量调整

方案2：工作表事件+动态数据验证实现搜索过滤 #

如果不想用ActiveX控件，可通过动态更新数据验证列表实现：
在Sheet1的代码模块中粘贴以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsSource As Worksheet
    Dim rSource As Range, rTemp As Range
    Dim wsTemp As Worksheet
    Dim filterText As String
    Dim lastRow As Long
    
    ' 仅处理C5单元格的输入
    If Target.Address <> "$C$5" Then Exit Sub
    
    filterText = Target.Value
    Set wsSource = ThisWorkbook.Sheets("Sheet2")
    
    ' 创建临时工作表存储过滤后的列表
    Set wsTemp = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    wsTemp.Name = "TempList"
    
    ' 复制数据源到临时表并执行过滤
    wsSource.Range("B1:B1000").Copy wsTemp.Range("A1")
    lastRow = wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp).Row
    
    If filterText <> "" Then
        wsTemp.Range("A1:A" & lastRow).AutoFilter Field:=1, Criteria1:="*" & filterText & "*"
    End If
    
    ' 获取过滤后的非空单元格
    On Error Resume Next
    Set rTemp = wsTemp.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' 更新数据验证列表
    With Target.Validation
        .Delete
        If Not rTemp Is Nothing Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=TempList!" & rTemp.Address
        Else
            ' 无匹配项时允许手动输入
            .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Formula1:="=TRUE"
        End If
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowError = False
    End With
    
    ' 删除临时表
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
End Sub

说明 #

• 输入内容时会自动过滤Sheet2的数据源，生成动态下拉列表
• 每次操作会临时创建工作表存储过滤结果，用完自动删除
• 支持模糊搜索，输入部分字符即可匹配对应选项

内容的提问来源于stack exchange，提问作者RK Singh