Excel VBA多条件匹配表头筛选行并复制指定列数据问题求解

原代码核心问题 #

• 筛选锚点设置错误，锚定B6单元格开启筛选会导致字段映射错位，多条件叠加筛选时无法实现「所有匹配列均为yes」的判断逻辑
• 单元格引用未做全限定，部分Range调用未指定父工作表，跨表运行时会默认取当前激活表数据，触发取值错误
• 未处理条件匹配失败的报错场景，一旦输入的条件在源表表头找不到对应列，直接抛出运行时错误
• 数据复制范围硬编码从C7开始，会遗漏表头下方紧邻的有效数据行
• 写入目标区域前未清空历史残留数据，新结果会和旧数据叠加
• 条件读取逻辑未兼容空值场景，条件单元格为空时会匹配错误内容

相关工作表参考 #

修正后可运行代码 #

Sub MatchAndCopyData()
    Dim wsCrit As Worksheet, wsSource As Worksheet, wsDest As Worksheet
    Dim critRng As Range, critCell As Range
    Dim matchCols As Collection
    Dim sourceLastRow As Long, i As Long, j As Long, isAllYes As Boolean
    Dim destRow As Long
    Dim headerRng As Range, foundCell As Range
    
    ' 绑定三个工作表对象，避免激活表切换导致的错误
    Set wsCrit = ThisWorkbook.Sheets("Criteria")
    Set wsSource = ThisWorkbook.Sheets("Source")
    Set wsDest = ThisWorkbook.Sheets("Destination")
    Set matchCols = New Collection
    
    ' 读取条件区域的非空值，自动跳过空单元格，支持1-6个条件灵活配置
    On Error Resume Next
    Set critRng = wsCrit.Range("B3,C3,B6,C6,B9,C9").SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If critRng Is Nothing Then
        MsgBox "条件表未录入任何有效匹配条件", vbExclamation
        Exit Sub
    End If
    
    ' 定位源表表头行，若实际表头不在第1行，修改此处行号即可
    Set headerRng = wsSource.Rows(1)
    
    ' 逐个匹配条件对应的源表列
    For Each critCell In critRng
        Set foundCell = headerRng.Find(What:=critCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not foundCell Is Nothing Then
            matchCols.Add foundCell.Column
        Else
            MsgBox "源表表头未找到匹配条件：" & critCell.Value, vbExclamation
            Exit Sub
        End If
    Next
    
    ' 清空目标区域旧数据，从E14开始写入
    wsDest.Range("E14:G" & wsDest.Rows.Count).ClearContents
    destRow = 14
    
    ' 获取源表C列（Name字段）最后一行有效数据行号
    sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row
    
    ' 逐行校验：所有匹配列值均为yes才提取数据
    For i = 2 To sourceLastRow
        isAllYes = True
        For j = 1 To matchCols.Count
            ' 自动忽略大小写、前后空格的格式差异
            If LCase(Trim(wsSource.Cells(i, matchCols(j)).Value)) <> "yes" Then
                isAllYes = False
                Exit For
            End If
        Next j
        
        If isAllYes Then
            ' 复制当前行C/D/E列到目标表对应位置
            wsSource.Range(wsSource.Cells(i, "C"), wsSource.Cells(i, "E")).Copy _
                Destination:=wsDest.Cells(destRow, "E")
            destRow = destRow + 1
        End If
    Next i
    
    MsgBox "处理完成，共匹配到 " & destRow - 14 & " 条符合要求的记录", vbInformation
End Sub

使用说明 #

• 如果源表表头不在第1行，只需修改代码中Set headerRng = wsSource.Rows(1)的行号，同时将数据遍历起始行For i = 2 To sourceLastRow中的2改成表头下第一行的行号即可
• 代码自动兼容条件单元格为空的场景，空条件会自动跳过，不会参与匹配
• 匹配判断自动忽略单元格值的前后空格、大小写差异，避免因为格式问题漏判

运行前请确认Excel宏安全设置已启用宏，否则代码无法正常执行。

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