VBA代码按日期过滤行，然后复制到主表

Question

我有一个包含多个工作表和一个主工作表的工作簿。我想搜索所有工作表并选择 A 列中日期为 120 天或更早的行，然后从第 11 行开始将这些行复制到主工作表。我查看了此代码：

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 09/05/2007 08:43
' Author    : Roy Cox (royUK)
' Website  :for more examples and Excel Consulting
' Purpose  : combine data from multiple sheets to one
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'            projects but please leave this header intact.

 Option Explicit


'---------------------------------------------------------------------------------------
' Procedure : Combinedata
' Author    : Roy Cox
' Website  : www.excel-it.com
' Date      : 10/10/2010
' Purpose  : Combine data from all sheets to a master sheet
'---------------------------------------------------------------------------------------
'
Sub Combinedata()

     Dim ws As Worksheet
     Dim wsmain As Worksheet
     Dim DataRng As Range
     Dim Rw As Long
     Dim Cnt As Integer
     Const ShtName As String = "Master" '<-destination sheet here
     Cnt = 1

     Set wsmain = Worksheets(ShtName)
     wsmain.Cells.Clear
     For Each ws In ThisWorkbook.Worksheets
         If ws.Name <> wsmain.Name Then
             If Cnt = 1 Then
                 Set DataRng = ws.Cells(2, 1).CurrentRegion
                 DataRng.copy wsmain.Cells(1, 1)
             Else: Rw = wsmain.Cells(Rows.Count, 1).End(xlUp).Row + 1
             MsgBox ws.Name & Rw
             Set DataRng = ws.Cells(2, 1).CurrentRegion
                 'don't copy header rows
                 DataRng.Offset(1, 0).Resize(DataRng.Rows.Count - 1, _
                                             DataRng.Columns.Count).copy ActiveSheet.Cells(Rw, 1)
             End If
         End If
         Cnt = Cnt + 1
     Next ws

End Sub

但这会将所有工作表转移到主控...

Answer 1

Option Explicit

Sub CopyRowByRow()

    Dim master As Worksheet, sheet As Worksheet
    Set master = Sheets("Sheet1")
    Dim i As Long, nextRow As Long
    master.Cells.ClearContents

    For Each sheet In ThisWorkbook.Sheets
        If sheet.Name <> master.Name Then
            For i = 1 To sheet.Range("A" & Rows.Count).End(xlUp).Row
                If Not IsEmpty(sheet.Range("A" & i)) Then
                    If DateDiff("d", Now(), sheet.Range("A" & i).Value) < -120 Then
                        nextRow = master.Range("A" & Rows.Count).End(xlUp).Row + 1
                        If nextRow = 2 And IsEmpty(master.Range("A" & nextRow).Offset(-1, 0)) Then
                            nextRow = 11
                        End If
                        sheet.Rows(i & ":" & i).Copy
                        master.Rows(nextRow & ":" & nextRow).PasteSpecial _
                            Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Application.CutCopyMode = False
                    End If
                End If
            Next i
        End If
    Next
End Sub