Copy 3 rows above and insert?

[hxrolan091]

Hi

I need help with this macro code. I just want to copy the content of 3 above with the number (91) and insert the copied rows below it and loop it.

and secondly. I have thousands of rows (17501). Is there other ways to speed up the copy and insert process?

Here is the marco code. I just can't seem to get the right.

Thanks in advance!!

Public Sub CopyRows()

Dim Col As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "D"
StartRow = 2
LastRow = Sheets("Sheet1").Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With Sheets("Sheet1")
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) = "91" Then
            'Cells(R + 1, Col).Offset(-3, 0).EntireRow.Copy
            '.Cells(R, Col).EntireRow.Insert Shift:=xlDown
            .Cells(R + 1, Col).EntireRow.Copy
            .Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
        End If
Next R
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
    
End Sub

Thanks in advance!!

 

[Joe4]

You are welcome.
Glad we got it all sorted out.