根据日期范围多次将行复制到另一个工作表

Question

我有一个大约 15 张工作表的 Excel 工作簿。我正在寻找一种根据 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