Copy multiple scattered rows from Sheet 1 to Sheet 2 at one time

heathermarie923 

Try this version:

Private Sub Workbook_Open()
    'Declaring variables
    Dim ws As Worksheet
    Dim wt As Worksheet
    Dim i As Long
    Dim Lastrow As Long
    Dim NewRecordsRow As Long
    Application.ScreenUpdating = False
    Set ws = Worksheets("List of UPCs")
    Set wt = Worksheets("Historical Data")
    Lastrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    NewRecordsRow = wt.Range("B" & wt.Rows.Count).End(xlUp).Row
    For i = 2 To Lastrow
        If ws.Cells(i, "E").Value < Date Then
            NewRecordsRow = NewRecordsRow + 1
            ws.Cells(i, "E").EntireRow.Copy Destination:=wt.Cells(NewRecordsRow, 1)
            ws.Range(ws.Cells(i, 3), ws.Cells(i, 5)).Clear
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox "Fill in any blank Column E fields with the formula =today(). This ensures certain functions act accordingly."
End Sub