今天跟大家分享下我们如何通过Deepseek来编写VBA代码，制作模糊搜索的下拉菜单，这个等来十来年的功能，用Deepseek竟然几分钟就搞定了，不得不感叹AI工具的强大，我们以后能干的过AI吗，这真的是个问题啊？

一、准备工作

1. 首先我们需先新建一个XLSM格式的Excel文件，这个文件能否保存宏代码

2. 打开文件，新建一个sheet，将名称更改数据：数据源

3. 在数据源这个sheet中的D列这个区域中来填写下拉的内容

4. 新建第二个sheet，我们是需要在这里实现模糊匹配的下拉菜单的

二、创建窗体

首先点击【开发工具】随后我们需要在里面找到【插入】选择【ActiveX控件】

在里面找到文本框（TextBox）和列表框（ListBox）直接插入即可，位置大小可以随意设置

之后需要点击【设计模式】退出设计模式，不然的话窗体不会生效。

三、使用代码

按下快捷键ALT+F11调出VBA的设置窗口，之后会在右侧看到对应的sheet名称，我们需要找到想要实现这个效果的sheet，在这里是sheet1，所以我们就双击sheet1，复制代码，将其直接按下快捷键Ctrl+V粘贴，最后按下快捷键Ctrl+S保存一下就可以了

设置完毕后，鼠标三击单元格，激活文本框，在里面输入即可自动匹配自己需要的数据

四、代码展示

' 在模块顶部声明常量
Const DATA_SHEET As String = "数据源" ' 数据源工作表名称
Const DATA_COL As String = "D" ' 数据源所在列
Const TARGET_COL As Integer = 1 ' 目标列（A列为1）
' 主选择事件
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not IsValidTarget(Target) Then
HideControls
Exit Sub
End If

ResetControls
PositionControls Target
LoadData
End Sub
' 输入实时处理
Private Sub TextBox1_Change()
UpdateSearchResults TextBox1.Text
End Sub
' 列表点击处理
Private Sub ListBox1_Click()
If ListBox1.ListIndex = -1 Then Exit Sub
ActiveCell.Value = ListBox1.Value
HideControls
End Sub
' ================ 核心功能函数 ================
' 验证目标单元格有效性
Private Function IsValidTarget(Target As Range) As Boolean
IsValidTarget = (Target.Column = TARGET_COL) And _
(Target.Row >= 2) And _
(Target.Count = 1)
End Function
' 隐藏控件
Private Sub HideControls()
ListBox1.Visible = False
TextBox1.Visible = False
ListBox1.Clear
TextBox1.Text = ""
End Sub
' 重置控件状态
Private Sub ResetControls()
TextBox1.Visible = True
ListBox1.Visible = True
TextBox1.Text = ""
ListBox1.Clear
End Sub
' 定位控件位置
Private Sub PositionControls(Target As Range)
' 文本框位置（覆盖单元格）
With TextBox1
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height
End With

' 列表框位置（下方展开）
With ListBox1
.Top = Target.Top + Target.Height
.Left = Target.Left
.Width = Target.Width * 1.5
.Height = Target.Height * 8
End With
End Sub
' 加载数据源
Private Sub LoadData()
Dim arr
With Worksheets(DATA_SHEET)
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, DATA_COL).End(xlUp).Row
If lastRow < 2 Then Exit Sub
arr = .Range(DATA_COL & "2:" & DATA_COL & lastRow).Value
End With
ListBox1.List = arr
End Sub
' 执行模糊搜索
Private Sub UpdateSearchResults(searchText As String)
Dim arr, results(), i As Long, k As Long

' 重新获取数据源
With Worksheets(DATA_SHEET)
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, DATA_COL).End(xlUp).Row
If lastRow < 2 Then Exit Sub
arr = .Range(DATA_COL & "2:" & DATA_COL & lastRow).Value
End With

' 清空搜索条件时显示全部
If Trim(searchText) = "" Then
ListBox1.List = arr
Exit Sub
End If

' 执行模糊匹配
ReDim results(1 To UBound(arr))
For i = 1 To UBound(arr)
If InStr(1, arr(i, 1), searchText, vbTextCompare) > 0 Then
k = k + 1
results(k) = arr(i, 1)
End If
Next

' 更新列表框
ListBox1.Clear
If k > 0 Then
ReDim Preserve results(1 To k)
ListBox1.List = results
Else
ListBox1.AddItem "无匹配结果"
End If
End Sub

五、其他事项

默认是在A列来实现这个效果的，如果你想在其他列实现这个模糊的搜索下拉，就需要对代码做一下修改，只需将前3行修改为自己对应的数据即可

Const DATA_SHEET As String = "数据源" ' 数据源工作表名称
Const DATA_COL As String = "D" ' 数据源所在列
Const TARGET_COL As Integer = 1 ' 目标列（A列为1）

如果你想要提高工作效率，不想再求同事帮你解决各种Excel问题，可以了解下我的专栏，WPS用户也能使用，讲解了函数、图表、透视表、数据看板等常用功能，AI的也已经在路上了，后期都会免费更新的