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

Hi, I wanted to insert blank rows below and copy and paste the rows above to those blank rows when certain conditions are met. For example when you see a value 112 in column E then insert a blank row below it and copy and paste that same row above containing the value 112 onto the blank row you just created and also when you see 159 in column E perform this function above. I started building this out but ran into issues. Can someone please take a look? I will much appreciate this. Thanks

Code

Sub pins()

Dim z1, z3, z4 As Range

Set z1 = Sheets("Sheet1").Range("E2:E15").End(xlDown)
Do Until z1.Row = 1

If z1.Value = "112" Then
z1.EntireRow.Offset(1).Insert
End If

Set z1 = z1.Offset(-1)
Loop

Dim z2 As Range
Set z2 = Sheets("Sheet1").Range("E2:E15").End(xlDown)
Do Until z2.Row = 1
If z2.Value = "112" Then
z2.EntireRow.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
z2.Offset(1).Paste
End If
Set z2 = z2.Offset(-1)
Loop
End Sub

Hi there,

The fundamental problem occurs in the following line:

    Set z2 = Sheets("Sheet1").Range("E2:E15").End(xlDown)

The equivalent line for z1 works because there are no blank cells in the range, but new rows will have been inserted before the above line of code is executed, and therefore z2 will refer to the cell immediately above the first newly-inserted row, rather than the last non-blank cell in the column.


Try the following routine and see if it does what you want:

Sub pins()

    Const sTEST_COLUMN  As String = "E"
    Const sTEST_VALUE   As String = "112"
    Const sSHEET_NAME   As String = "Sheet1"
    Const iSTART_ROW    As Integer = 2

    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 Until rTestCell.Row = iSTART_ROW

        If rTestCell.Value = sTEST_VALUE Then
            rTestCell.EntireRow.Offset(1, 0).Insert
        End If

        Set rTestCell = rTestCell.Offset(-1, 0)

    Loop

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

    Do Until rTestCell.Row = iSTART_ROW

        If rTestCell.Value = sTEST_VALUE Then
            rTestCell.EntireRow.SpecialCells(xlCellTypeVisible).Copy
            wks.Paste Destination:=rTestCell.EntireRow.Offset(1, 0)
        End If

        Set rTestCell = rTestCell.Offset(-1, 0)

    Loop

End Sub

Defining the various parameters as Const(ants) keeps them in a convenient location in case they ever need to be changed in response to changes in worksheet layout etc.


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

Regards,

Greg M

Thanks Greg M, I ran your code it's almost perfect to what I was looking for, but just few questions. If I have multiple values in column E like 112, 159, 687 etc, how will I list those constants to achieve the same goal you did with just 112? And also it seems that Const iSTART_ROW As Integer = 2 has to be changed to Const iSTART_ROW As Integer = 1 to execute for row 2 is this correct? Thanks again

Hi -

Please try this one and let me know;

Sub test()
Dim lr%, i%
With Application
    .ScreenUpdating = False
    .CutCopyMode = False
End With
lr = Cells(Rows.Count, 5).End(xlUp).Row + 1
For i = lr To 5 Step -1
    If (Cells(i + 1, 5).Value <> "112" And Cells(i, 5).Value = "112") Or (Cells(i + 1, 5).Value <> "159" And Cells(i, 5).Value = "159") Then
        Rows(i).Copy
        Rows(i + 1).Insert
    End If
Next
With Application
    .ScreenUpdating = True
    .CutCopyMode = True
End With
End Sub

event

Thanks event21, I ran your code and still digesting it. It seems when I have only few rows of data, it does not seem to work e.g. 4 rows of data. If I have many rows it works but only executes for the rest but not the first row of data in this case row 2 where the first value in column E is 112. I am still digesting your code though Lol.

Hi -

on this line

For i = lr To 5 Step -1

the number 5 is the first row of data, like in your file the row data starts in row # 5 so if your row data starts in row 1 or row 2 then change this line appropriately

event

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.

Another:

Sub pato225()
Dim i As Long
For i = Range("E" & Rows.Count).End(3).row To 2 Step -1
    Select Case Cells(i, "E").Value
        Case Is = 112, 159, 687
            Rows(i).Copy
            Rows(i).Insert
    End Select
Next i
End Sub

I would have done it like John. its quick , clean and simple
I may not have use the copy function. I probably would have use

Rows(i+1).insert
rows(i+1).value = rows(i).value

this way I can avoid the paste function, and i find it runs a bit quicker then copy past.

Hi Steve7913/John, thank you for the comments I will ran the codes. This only gives me more options and a good learning experience of all the different ways of VBA programming.

Thanks, Pato - please continue to keep me informed.

Best regards,

Greg M