Insert Blank Rows and Copy Rows Above it with Data to These blank rows With Conditions

Hi there,

The following changes should do what you need:

Sub pins()

    Const sTEST_COLUMN  As String = "E"
    Const sTEST_VALUE_1 As String = "112"
    Const sTEST_VALUE_2 As String = "@@@"
    Const sTEST_VALUE_3 As String = "###"
    Const sSHEET_NAME   As String = "Sheet1"
    Const iSTART_ROW    As Integer = 5

    Dim rTestCell       As Range
    Dim rLastCell       As Range
    Dim wks             As Worksheet

    Set wks = Worksheets(sSHEET_NAME)

    Set rLastCell = wks.Range(sTEST_COLUMN & iSTART_ROW).End(xlDown)

    Set rTestCell = rLastCell

    Do While rTestCell.Row >= iSTART_ROW

        If rTestCell.Value = sTEST_VALUE_1 Or _
           rTestCell.Value = sTEST_VALUE_2 Or _
           rTestCell.Value = sTEST_VALUE_3 Then

               rTestCell.EntireRow.Offset(1, 0).Insert

        End If

'       Specify the cell above unless the current cell is at the top of the worksheet
        If rTestCell.Row > 1 Then
              Set rTestCell = rTestCell.Offset(-1, 0)
        Else: Exit Do
        End If

    Loop

    Set rTestCell = rLastCell  '   The location of rLastCell is automatically updated as new rows are inserted

    Do While rTestCell.Row >= iSTART_ROW

        If rTestCell.Value = sTEST_VALUE_1 Or _
           rTestCell.Value = sTEST_VALUE_2 Or _
           rTestCell.Value = sTEST_VALUE_3 Then

            rTestCell.EntireRow.SpecialCells(xlCellTypeVisible).Copy
            wks.Paste Destination:=rTestCell.EntireRow.Offset(1, 0)

        End If

'       Specify the cell above unless the current cell is at the top of the worksheet
        If rTestCell.Row > 1 Then
              Set rTestCell = rTestCell.Offset(-1, 0)
        Else: Exit Do
        End If

    Loop

End Sub

Well done for noticing that the first row wasn't tested in the previous version of my code!

iSTART_ROW is the number of the row from which testing should begin - I think that 5 is probably the correct value for your worksheet.

These lines are included as a general "safety net", but are probably not required in this instance.

Hope this helps - as before, please let me know how you get on.

Regards,

Greg M

Thank you Greg, I will run this and It looks like I might mark this thread resolved soon.