Loop through row if the value found copies the entire row and paste it under / down

advertisements

I have spent some trying getting my code to work and looking through various example but still cant get it to work properly.

I have a table where I want to loop through all rows and if "Pro" found in column B , copy the whole row and paste it once either underneath the row or at the very bottom(ideally) (Picture attached before and after the code)

I tried with the below code but all it does is finding the first instance of "Pro" in column B and copying same row until range 50 reaches:

sub Loop()
Dim i As Long
For i = 1 To 50
Range("B" & i).Select
If Range("B" & i).Value = "Pro" Then
Rows(i).EntireRow.Copy
Rows(i + 1).Insert Shift:=xlDown

End If
 Next i
End Sub

I tried with (For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row ) as well, defining last column but same thing happens(end up copying same row over and over again until the specified range finish).

If this will be too easy, I want for a copied row to have a value in Column A changed as well from as an exaple Req2 to Req2Pro

https://i.stack.imgur.com/AnWNH.jpg


Edit this line:

Rows(i).EntireRow.Copy
Rows(i + 1).Insert Shift:=xlDown

With:

Rows(i + 50).Value = Rows(i).Value
Range("A" & i + 50).value =  Range("A" & i).value & "Pro"

This is it in the code:

 Sub testloop()
 Dim i As Long
 Dim Find_last_row as long
 Find_last_row = cells(rows.count,1).end(xlup).row

 For i = 1 To Find_last_row
    If Range("B" & i).Value = "Pro" Then
       Rows(i + Find_last_row).Value = Rows(i).Value
       Range("A" & i + Find_last_row).value =  Range("A" & i).value & "Pro"
    End If
 Next i
 End Sub