Deleting rows older than current date and inserting a new row

[Dan E.]

I have a workbook which contains a worksheet that has project data, including
project end date. Users update the sheet with current and projected
projects. I have written a macro to remove entries whose end date (in column
"G") are older than the current date.

The macro as written works, however when I run the macro it inserts a blank
row for every project listed in the spreadsheet. How do I get it to insert a
new row only when it deletes a row? And how do I make sure that the new,
inserted row is at the bottom of the formatted data (which ends at row 31)?

Sub DeleteOldRows()
Dim LastRow As Long, xR As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "G").End(xlUp).Row
For xR = LastRow To 6 Step -1
If .Cells(xR, "G") < Date Then _
Rows(xR).EntireRow.Delete
Rows(31).EntireRow.Insert
Next xR
End With

End Sub

Thanks for your help!

 

[Bernie Deitrick]

Dan,

Change

If .Cells(xR, "G") < Date Then _
Rows(xR).EntireRow.Delete
Rows(31).EntireRow.Insert

to

If .Cells(xR, "G") < Date Then
Rows(xR).EntireRow.Delete
Rows(31).EntireRow.Insert
end if


HTH,
Bernie
MS Excel MVP

 

[Dan E.]

Bernie - did as suggested, now it will not add additional rows. It deletes
fine, but the add command doesn't seem to be executed.

OK, updated code:

Sub DeleteOldRows()
Dim LastRow As Long, xR As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "G").End(xlUp).Row
For xR = LastRow To 6 Step -1
If .Cells(xR, "G") < Date Then
Rows(xR).EntireRow.Delete
Rows(31).EntireRow.Insert
End If
Next xR
End With

End Sub

 

[Bernie Deitrick]

Dan,

Sure, it is inserting rows - they're just blank. Insert the numbers 1
through 45 in column A (or any other blank column) to see what it does.

But what row should be copied? Perhaps, change to this, to copy the current
31st row, and increment the date in column G:

Sub DeleteOldRows2()
Dim LastRow As Long, xR As Long

LastRow = Cells(Rows.Count, "G").End(xlUp).Row
For xR = LastRow To 6 Step -1
If Cells(xR, "G") < Date Then
Rows(31).EntireRow.Copy
Rows(31).Insert Shift:=xlDown
Rows(xR).EntireRow.Delete
Range("G31").Value = Range("G30").Value + 1
End If
Next xR

End Sub

Note that With Activesheet is Excel's default, and is rarely needed.

HTH,
Bernie
MS Excel MVP

 

[Dan E.]

Bernie,

Appreciate the tip. I did what you said and realized that I was inserting
the new rows outside of my formatted area, that's why it looked like it
wasn't working. Then I realized I could use the LastRow variable to insert
after the last bit of data in my table. And I used the with ActiveSheet just
to keep anything unexpected from happening

Final code below for future use:

Sub DeleteOldRows()
Dim LastRow As Long, xR As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "G").End(xlUp).Row
For xR = LastRow To 6 Step -1
If .Cells(xR, "G") < Date Then
Rows(xR).EntireRow.Delete
Rows(LastRow).EntireRow.Insert
End If
Next xR
End With

End Sub