VBA find phrase and move rows to bottom of sheet

Euro5
Euro5 used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Older than dirt
Most Valuable Expert 2017
Distinguished Expert 2018
Commented:
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

Top Expert 2014

Commented:
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

Author

Commented:
Perfect!
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial