VBA find phrase and move rows to bottom of sheet

Referring to the attached, I need a code to find the phrase including PRP, then find the table right below, then choose all the rows and move to the bottom of the data - second blank row.

This must be VBA.

For instance, once PRP is found, rows 38 through 190 would be cut and pasted to row 441.
Extremely important.

Can anyone help?
Sample-PRP.xlsx
Euro5Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Sub MovePRP()
Dim lngRow As Long

Dim rngPRP As Range

With ActiveSheet
    Set rngPRP = .Cells.Find(What:="PRP", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If Not rngPRP Is Nothing Then
        For lngRow = rngPRP.Row + 2 To .UsedRange.Rows.Count
            If .Cells(lngRow, 1) = "" Then
                lngRow = lngRow - 1
                Exit For
            End If
        Next
    End If
    
    .Rows(rngPRP.Row & ":" & lngRow).Cut
    .Cells(.UsedRange.Rows.Count + 1, 1).EntireRow.Insert
End With
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
aikimarkCommented:
Option Explicit

Sub Q_28698263()
    Dim rngSrc As Range
    Dim rngTgt As Range
    Dim wks As Worksheet
    Set wks = Worksheets("Sheet1")
    Set rngSrc = wks.Cells.Find("PRP")
    Debug.Print rngSrc.Address
    Set rngSrc = rngSrc.End(xlDown)
    Set rngSrc = wks.Range(rngSrc, rngSrc.End(xlDown))
    Set rngTgt = wks.Cells.SpecialCells(xlCellTypeLastCell).End(xlToLeft)
    rngSrc.EntireRow.Copy rngTgt
    rngSrc.EntireRow.Delete
End Sub

Open in new window

0
Euro5Author Commented:
Perfect!
0
Martin LissOlder than dirtCommented:
Note that my solution only works for the first "PRP" it finds. In other words if there were two, the second wouldn't be moved.
0
Martin LissOlder than dirtCommented:
If there's a possibility of more than one "PRP" then use this version instead.

Sub MovePRP()
Dim lngRow As Long
Dim lngEnd As Long
Dim lngLastRow As Long

With ActiveSheet
    lngLastRow = .Range("A1048576").End(xlUp).Row
    For lngRow = lngLastRow To 1 Step -1
        If InStr(.Cells(lngRow, 1), "PRP") > 0 Then
            For lngEnd = lngRow + 2 To lngLastRow + 1
                If .Cells(lngEnd, 1) = "" Then
                    ' Normally cut and paste the range to the end of the sheet,
                    ' but if it's already at the end don't do anything
                    If lngEnd <> lngLastRow + 1 Then
                        .Rows(lngRow & ":" & lngEnd - 1).Cut
                        .Cells(lngLastRow + 1, 1).EntireRow.Insert
                    End If
                    Exit For
                End If
            Next
        End If
    Next
End With

Open in new window

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.