Копировать строки на другой лист на основе диапазона дат несколько раз

Question

У меня есть книга Excel, в которой ~ 15 листов. Я ищу способ скопировать строки на новый лист на основе диапазона дат в столбце K.

Пример:

Лист 1: Диапазон дат (1/1/15 - 1/1/18) -> Копировать все строки в пределах временного диапазона в Лист 4

Лист 2: Диапазон дат (1/1/15 - 1/1/18) -> Копировать все строки в пределах временного диапазона в Лист 5

Лист 3: Диапазон дат (1/1/15 - 1/1/18) -> Копировать все строки в пределах временного диапазона на Лист 6

и т.д.

Код, который выполняет работу по одному листу за раз, но я бы хотел, чтобы он работал за один раз:

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

Я пытался добавить еще один оператор For для других листов, но он не работал.

Answer 1

Массив листов

Добавлены переменные:

• j - Счетчик листов
• str1 - Список листов для копирования с
• str2 - Список листов для копирования на
• vnt1 - массив листов для копирования с
• vnt2 - Массив листов для копирования на

Код

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