Sub InsertRows()
Application.ScreenUpdating = False
Dim NumRows As Integer
Dim Lrow As Long
Dim r As Long
Lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
NumRows = 2
For r = Lrow To 1 Step -1
ActiveSheet.Rows(r + 1).Resize(NumRows).EntireRow.Insert
Next r
Application.ScreenUpdating = True
End Sub
Gord Dibben MS Excel MVP