考虑到使用 VBA 满足某些情况，如何在多个工作表中复制某个值的所有实例？

Question

我有一个现有代码，可以循环遍历多个工作表，并将 B 列和 D 列中具有值（但 P 为空）的行复制到报告工作表。我怎样才能让它在所有工作表的 D 列中搜索所有相同的值并复制到报告表，同时保持原始代码完整？例如：表 1 上的第 1、2 和 3 行满足要求，将被复制到报告表中。表 2 上的第 1 行不满足要求，但单元格 D1 与表 1 上的 D1 相同。我希望它复制所有 4 行。

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)

Dim srcSheet As Object, srcRange As Range, srcRow As Range
    
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
                srcRow.Copy Destination:=rptCell
                Set rptCell = rptCell.Offset(1)
            End If
        Next srcRow
    End If
Next srcSheet

Answer 1

收集复制行的所有唯一“D”值，然后运行第二个循环来搜索这些值，不包括已复制的行。

类似这样的：

Sub Tester()

    Dim wb As Workbook, srcSheets As Sheets, rptSheet As Worksheet, rptCell As Range
    Dim srcSheet As Object, srcRange As Range, srcRow As Range, run As Long
    Dim dict As Object, dVal
    
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = 1 'case-insentive
    Set wb = ThisWorkbook
    Set srcSheets = wb.Sheets(Array("sheet1, sheet2, sheet3, sheet4, sheet5"))
    
    Set rptSheet = wb.Sheets("Report")
    Set rptCell = rptSheet.Cells(rptSheet.Rows.Count, "A").End(xlUp).Offset(1)
    
    For run = 1 To 2
        For Each srcSheet In srcSheets
            If TypeOf srcSheet Is Worksheet Then
                Set srcRange = srcSheet.Range("A5:N358")
                For Each srcRow In srcRange.Rows
                    dVal = CStr(srcRange.Columns("D").Value)
                    If CopyRow(srcRow) And run = 1 Then 'first run copies valid rows
                        CopyToNext srcRow, rptCell
                        dict(dVal) = True 'remember colD value
                    Else
                        If run = 2 Then 'copying D matches for otherwise invalid rows on second run...
                            If dict.Exists(dVal) Then
                                CopyToNext srcRow, rptCell
                            End If
                        End If
                    End If
                Next srcRow
            End If
        Next srcSheet
    Next run
End Sub

'does a row meet the criteria to be copied?
Function CopyRow(rw As Range) As Boolean
    If Len(rw.Columns("B").Value) > 0 Then
        If Len(rw.Columns("P").Value) = 0 Then
             CopyRow = Len(rw.Columns("D").Value) > 0
        End If
    End If
End Function

'helper sub
Sub CopyToNext(ByRef rwToCopy As Range, ByRef destCell As Range)
    rwToCopy.Copy destCell
    Set destCell = destCell.Offset(1) 'next paste location
End Sub