Copy/Paste rows if contains specific text, in a list

[hs126]

Hi all

I'm stuck on this problem and hoping someone can help.

I have a list of data- (up to 1000 rows)
I want to find text “Address” and each time it’s found, copy and paste 4 rows (address and the 3 rows below). It would be great if these could be pasted under the cell containing the word “Name”.

i.e.
Before
[TABLE="width: 100"]
<tbody>[TR]
[TD]A[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Address[/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
</tbody>[/TABLE]


After
[TABLE="width: 100"]
<tbody>[TR]
[TD]A[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Address[/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Y[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


If anyone can help that would be amazing, Thanks!

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub CutMoveUp()
   Dim Addar As Areas
   Dim Namear As Areas
   Dim i As Long
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Replace "Address", "=XXX", xlWhole, , False, , False, False
      Set Addar = .SpecialCells(xlFormulas, xlErrors).Areas
      .Replace "=XXX", "Address", xlWhole, , False, , False, False
      .Replace "Name", "=XXX", xlWhole, , False, , False, False
      Set Namear = .SpecialCells(xlFormulas, xlErrors).Areas
      .Replace "=XXX", "Name", xlWhole, , False, , False, False
   End With
   For i = 1 To Addar.Count
      If Addar(i).Row > Namear(i).Row + 1 Then
         Addar(i).Resize(4).EntireRow.Cut
         Namear(i).Offset(1).EntireRow.Insert
      End If
   Next i
Application.CutCopyMode = False
End Sub

 

[hs126]

Thank you that works brilliantly

I appreciate the help
Thanks

 

[Fluff]

Glad to help & thanks for the feedback