CODEWITHSUNDEEP
excelvba
Seashore
Seashore

Reputation: 13

Copy Rows to Another Sheet Based on Date Range Multiple Times

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.

Upvotes: 1

Views: 1829

Answers (1)

VBasic2008
VBasic2008

Reputation: 54817

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

Upvotes: 1

Related Questions