如何在保留原有VBA逻辑下，复制多工作表中指定列值匹配的所有行

核心思路 #

要实现需求，分两步处理即可：

1. 先遍历所有目标工作表，收集**符合原条件（B、D列非空且P列为空）**的行的D列值，用字典存储来避免重复值；
2. 再次遍历所有目标工作表，把所有D列值在字典中的行，全部复制到Report工作表。

修改后的完整代码 #

Sub CopyMatchingRows()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim srcSheets As Sheets: Set srcSheets = wb.Sheets(Array("sheet1", "sheet2", "sheet3", "sheet4", "sheet5"))
    Dim rptSheet As Worksheet: Set rptSheet = wb.Sheets("Report")
    Dim rptCell As Range: Set rptCell = rptSheet.Cells(rptSheet.Rows.Count, "A").End(xlUp).Offset(1)
    
    ' 用字典存储符合原条件的D列值，自动去重
    Dim targetDValues As Object: Set targetDValues = CreateObject("Scripting.Dictionary")
    Dim srcSheet As Object, srcRange As Range, srcRow As Range
    Dim dValue As String
    
    ' 第一步：遍历收集符合原条件的D列值
    For Each srcSheet In srcSheets
        If TypeOf srcSheet Is Worksheet Then
            Set srcRange = srcSheet.Range("A5:N358")
            For Each srcRow In srcRange.Rows
                ' 原条件判断逻辑保留
                If Len(CStr(srcRow.Columns("B").Value)) > 0 And _
                   Len(CStr(srcRow.Columns("P").Value)) = 0 And _
                   Len(CStr(srcRow.Columns("D").Value)) > 0 Then
                    dValue = CStr(srcRow.Columns("D").Value)
                    If Not targetDValues.Exists(dValue) Then
                        targetDValues.Add dValue, True
                    End If
                End If
            Next srcRow
        End If
    Next srcSheet
    
    ' 第二步：遍历复制所有匹配D列值的行
    For Each srcSheet In srcSheets
        If TypeOf srcSheet Is Worksheet Then
            Set srcRange = srcSheet.Range("A5:N358")
            For Each srcRow In srcRange.Rows
                dValue = CStr(srcRow.Columns("D").Value)
                ' 判断当前行D值是否在目标集合中
                If targetDValues.Exists(dValue) Then
                    srcRow.Copy Destination:=rptCell
                    Set rptCell = rptCell.Offset(1)
                End If
            Next srcRow
        End If
    Next srcSheet
    
    ' 释放对象，避免内存泄漏
    Set targetDValues = Nothing
    Set srcRange = Nothing
    Set srcSheet = Nothing
    Set rptSheet = Nothing
    Set wb = Nothing
End Sub

关键改动说明 #

• 新增Scripting.Dictionary存储目标D列值，自动去重，避免重复处理相同值；
• 拆分两次遍历：第一次收集符合原条件的D值，第二次批量复制所有匹配行，逻辑清晰且高效；
• 完全保留原代码的工作表、行范围判断逻辑，确保兼容性；
• 新增对象释放代码，规范内存管理。

注意事项 #

• 代码用后期绑定创建字典，无需手动引用Microsoft Scripting Runtime，兼容性更强；
• Report工作表的起始行从原有数据的下一行开始，不会覆盖已有内容；
• 若需要调整行范围（原代码为A5:N358），直接修改srcRange的赋值即可。

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