Copy Rows to Another Sheet Based on Date Range Multiple Times

Question

I have an Excel workbook that has ~15 sheets. I'm looking for a way to copy rows to a new sheet based on the date range in column K.

Example:

Sheet 1: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 4

Sheet 2: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 5

Sheet 3: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 6

etc.

Code which does the job one sheet at a time, but I would like it to work on one go:

Sub Date_Sample()
    Application.ScreenUpdating = False
    On Error GoTo M
    Dim i As Long
    Dim ans As Date
    Dim anss As Date
    Dim Lastrow As Long
    Dim Lastrowa As Long
    ans = InputBox("Start Date Is")
    anss = InputBox("End Date Is")
    Lastrowa = Sheets("Sheet1").Cells(Rows.Count, "K").End(xlUp).Row
    Lastrowb = Sheets("Sheet4").Cells(Rows.Count, "K").End(xlUp).Row + 1
    For i = 1 To Lastrowa
        If Cells(i, "K").Value >= ans And Cells(i, "K").Value <= anss Then
            Rows(i).Copy Destination:=Sheets("Sheet4").Rows(Lastrowb)
            Lastrowb = Lastrowb + 1
            Rows(i).EntireRow.Delete
            i = i - 1
        End If
    Next i
    Application.ScreenUpdating = True
    Exit Sub
M:
    MsgBox "Wrong Date"
    Application.ScreenUpdating = True
End Sub

I tried adding another For statement for the other sheets but it did not work.

1) Use AutoFilter to get the data. 2) Loop through each worksheet. 3) Use Select Case on the worksheet name to determine on which worksheet the data will be copied . — Scott Holtzman

VBasic2008 VBasic2008 · Accepted Answer · 2019-01-07T21:03:26

Array of Sheets

Added variables:

j - Sheets Counter
str1 - List of sheets to copy from
str2 - List of sheets to copy to
vnt1 - Array of sheets to copy from
vnt2 - Array of sheets to copy to

The Code

Sub Date_Sample()

    Application.ScreenUpdating = False

    On Error GoTo M

    Const str1 As String = "Sheet1,Sheet2,Sheet3"
    Const str2 As String = "Sheet4,Sheet5,Sheet6"

    Dim vnt1 As Variant
    Dim vnt2 As Variant
    Dim i As Long
    Dim j As Integer
    Dim ans As Date
    Dim anss As Date
    Dim Lastrow As Long
    Dim Lastrowa As Long

    ans = InputBox("Start Date Is")
    anss = InputBox("End Date Is")
    vnt1 = Split(str1, ",")
    vnt2 = Split(str2, ",")

    For j = 0 To UBound(vnt1)
        Lastrowa = Sheets(vnt1(j)).Cells(Rows.Count, "K").End(xlUp).Row
        Lastrowb = Sheets(vnt2(j)).Cells(Rows.Count, "K").End(xlUp).Row + 1
        For i = 1 To Lastrowa
            With Sheets(vnt1(j))
                If .Cells(i, "K").Value >= ans _
                        And .Cells(i, "K").Value <= anss Then
                    .Rows(i).Copy Destination:=Sheets(vnt2(j)).Rows(Lastrowb)
                    Lastrowb = Lastrowb + 1
                    .Rows(i).EntireRow.Delete
                    i = i - 1
                End If
            End With
        Next i
    Next j

    Application.ScreenUpdating = True

    Exit Sub
M:
    MsgBox "Wrong Date"
    Application.ScreenUpdating = True
End Sub

Copy Rows to Another Sheet Based on Date Range Multiple Times

1 Answers

Array of Sheets

Added variables:

The Code