Forum Discussion

heathermarie923's avatar
heathermarie923
Copper Contributor
Sep 14, 2022
Solved

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

Okay forum.  One more post, I'm sorry.

 

So, my end goal is to have an automated spreadsheet that every time you open it it automatically looks at column E in Sheet 1 (List of UPCs) and if the date has passed, it will copy the row to sheet 2 (Historical Data) and clear C through E of that row on sheet 1.

 

So in my case,  I set up some test rows with different past dates.

 

 

I closed out my sheet, ready to test my code by opening the workbook.  The clear function works.

 

 

But the copying only picked up one of the rows that met the condition.

 

 

What am I doing wrong in my code?  Or how can I fix this so that it picks up ALL rows that meet the condition?

 

Here is my code:

 

Private Sub Workbook_Open()

MsgBox "Fill in any blank Column E fields with the formula =today(). This ensures certain functions act accordingly."

'Delcaring variables
Dim i, Lastrow As Long

Lastrow = Sheets("List of UPCs").Range("B" & Rows.Count).End(xlUp).Row
LastRecordsRow = Sheets("Historical Data").Range("B" & Rows.Count).End(xlUp).Row
NewRecordsRow = LastRecordsRow + 1

For i = 2 To Lastrow
If Sheets("List of UPCs").Cells(i, "E").Value < Date Then
Sheets("List of UPCs").Cells(i, "E").EntireRow.Copy Destination:=Sheets("Historical Data").Cells(NewRecordsRow, 1)
Sheets("List of UPCs").Range(Cells(i, 3), Cells(i, 5)).Clear

End If
Next i

End Sub

Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Sep 14, 2022

    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
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Sep 14, 2022

    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

Resources