Excel VBA搜索工具改造需求：支持多非空单元格输入匹配返回对应行

前置准备 #

先选中你用来输入多个检索条件的所有单元格，在Excel左上角的名称框输入SEARCH_CONDITIONS后按回车，给输入区域设置命名，后续调整输入范围只要修改这个命名区域即可，不用改代码。

核心修改说明 #

• 修复原代码中检索值赋值的逻辑错误（原代码连续两个等于号会导致检索值变成布尔值，无法正常匹配）
• 自动收集输入区域内所有非空的检索条件，统一转小写存储，支持文本、数值混合格式输入
• 新增行匹配标记，避免同一行匹配多个条件时被重复输出
• 匹配规则为行内任意单元格匹配任意一个检索条件就返回该行，如需调整为同时匹配所有条件才返回，可自行修改判断逻辑

调整后完整代码 #

Sub Search()
  Call Searchfunction
End Sub

Sub Searchfunction()
    Application.ScreenUpdating = False
    
    '定义工作簿、工作表变量
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim condArr As Variant, condCount As Long
    Dim i As Long, isMatch As Boolean, isRowOutput As Boolean
    
    '绑定搜索工具文件
    Set wb1 = ActiveWorkbook
    Set ws1 = ActiveSheet
    
    '打开数据源文件
    Set wb2 = Workbooks.Open("C:\Users\Paul Baghramian\OneDrive - APT CuttingB.V\APTC_Engineering\99-APTC-Drawing List\APT_Cutting_Drawing_List.xlsx")
    Set ws2 = wb2.Worksheets("APT Drawing List")
    
    '清空原有输出结果
    ws1.Range("8:250") = ""
    
    '收集所有非空检索条件
    condCount = 0
    ReDim condArr(1 To 1000) '预留足够的条件存储空间
    For Each cell In ws1.Range("SEARCH_CONDITIONS")
        If Trim(cell.Value) <> "" Then
            condCount = condCount + 1
            condArr(condCount) = LCase(Trim(cell.Value))
        End If
    Next
    '如果没有输入检索条件直接退出
    If condCount = 0 Then
        wb2.Close SaveChanges:=False
        Application.ScreenUpdating = True
        MsgBox "请输入检索条件"
        Exit Sub
    End If
    ReDim Preserve condArr(1 To condCount)
    
    outputrow = 8
    
    '遍历数据源所有行
    For Row = 2 To 2000
        isRowOutput = False '标记当前行是否已经输出过，避免重复
        '遍历当前行所有列
        For Column = 1 To 14
            If isRowOutput = True Then Exit For '已经输出就跳过当前行剩余列的判断
            text_in_cell = LCase(ws2.Cells(Row, Column).Value)
            '判断当前单元格是否匹配任意一个检索条件
            isMatch = False
            For i = 1 To condCount
                If InStr(text_in_cell, condArr(i)) > 0 Then
                    isMatch = True
                    Exit For
                End If
            Next
            '匹配成功则复制整行
            If isMatch Then
                ws2.Range("A" & Row & ":N" & Row).Copy Destination:=ws1.Range("A" & outputrow)
                outputrow = outputrow + 1
                isRowOutput = True
            End If
        Next Column
    Next Row
    
    '关闭数据源文件，不保存修改
    wb2.Close SaveChanges:=False
    ws1.Activate
    
    Application.ScreenUpdating = True
End Sub

可选调整说明 #

• 如果不想用命名区域，可将代码中ws1.Range("SEARCH_CONDITIONS")替换为实际输入区域地址，例如ws1.Range("B2:B10")
• 如果需要实现「同时匹配所有检索条件才返回行」的逻辑，可修改匹配判断部分的代码，将匹配任意条件的判断改为全部条件匹配即可
• 若数据量超出2000行，可调整遍历行的上限数值，提高检索覆盖范围

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