VBA Copy and Delete Rows loop optimisation

Question

I'm trying to identify which cells in Column C in a spreadsheet of data are dates and if they are, then check if that date is older than 2 years old. If the second condition is met then the below code should copy the entire row from sheet "DUP_ALL" to a new sheet (Archive) and then delete the copied row from the "DUP_ALL" sheet.

I believe it works but I was wondering if there are any better ways to optimise my code.

Is it more efficient to stay in the first loop and copy and delete the rows at the same time or is it better to copy all the rows, then loop through a second time deleting all the rows that meet the same criteria.

I tried doing a copy and then delete in the same for loop to begin with but it kept producing an error "Run Time 1004: Method 'Range' of Object '_worksheet' failed"

Any help with optimising the below is greatly appreciated

Sub TestArchive() Dim sh As Worksheet, lr As Long, rng As Range, sh2 As Worksheet, lr2 As Long, c As Range Set sh = Sheets("DUP_ALL") 'Edit sheet name Set sh2 = Sheets("Archive") 'Edit Sheet name lr = sh.Cells(Rows.Count, 1).End(xlUp).Row Set rng = sh.Range("C2:C" & lr) For Each c In rng If IsDate(c.Value) Then If c.Value < Date - 456 Then lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1 c.EntireRow.Copy sh2.Range("A" & lr2) End If End If Next For Each c In rng If IsDate(c.Value) Then If c.Value < Date - 456 Then lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 c.EntireRow.Delete sh.Range("A" & lr1) End If End If Next End Sub 

Answer 1

I've found that if you are deleting rows in a range you need to create a for loop that starts at the bottom and works your way up. When you are using the for each loop and try deleting an item out of that range and keep looping it destroys the reference to that range. The next iteration will throw an error.

Here's an example, (I'm just pulling this out of my head and haven't tested it, but it should get you in the right direction)

... dim sh1Rows as integer dim myCell as range sh1Rows = sh.["A1"].end(xlDown).row for i = sh1Rows to 1 step -1 set myCell = sh["A1"].offset(0,i) if IsDate(myCell.value) and myCell.value < Date - 456 Then sh2.cells(1,sh2.["A1"].end(xlDown) +1).entirerow = myCell.entirerow.value myCell.entirerow.delete end if next