Copy Row based on Cell Value and Paste Below

[Lindsay0385]

Hello -

I found a code online that I'm trying to edit to fit my situation, but I keep on getting errors when I run it.

Here's what I want to do: Column A is empty except for cells with the value "x". I want to copy the rows that contain "x" in Column A and insert the rows directly below the last row with the value "x". There are a total of 11 cells that contain "x" in Column A and they are continuous.

I originally had a macro that worked with copying and pasting specific rows, but it no longer worked if rows were inserted above the rows I wanted to copy, so I was hoping marking the rows with "x" then copying them could be a work around.

Advise would be appreciated! Thanks, Lindsay

Sub copy_rows()
   
'Determine last Row with data in Column A
  lastRw = Cells(Rows.Count, "A").End(xlUp).Row
'Loop through rows in reverse order
    For rw = lastRw To 4 Step -1
'If Column A = "x", insert Rows
     If Cells(rw, "A") = "x" Then
       For newRw = 1 To Cells(rw, "A")
         Cells(rw, "A").EntireRow.Copy
         Cells(rw, "A").EntireRow.Insert shift:=xlDown
       Next
     End If
    Next
    
End Sub

 

[Lindsay0385]

Well, I found a work around using the macro recorder and relative references. Instead of using "x" to identify the rows to copy, I created a cell in white font with the words "copy here" and used the recorder to find the cell and copy rows based on that location. Seems to work well, though it's not elegant!

Cells.Find(What:="copy here", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
    
    ActiveCell.Rows("1:11").EntireRow.Select
    Selection.Copy
    ActiveCell.Offset(11, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown