多次基于日期范围将行复制到另一张工作表

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