So, it will be pretty obvious how new I am when you look at my unconventional code, but the code has worked perfectly up until I copied what I thought was a solution off of the forum. Daily I process a file that has some extreme formatting. This is a tiny piece of the pie. I am trying to find the word "BALTIMORE" and cut the entire row(s) that contain the selection and paste/insert the rows just above the first row with the word "THURMONT" in it. My code only works if BALTIMORE is found but hangs when it is not found. I would also like to insert 2 blank rows above insertion point. Thanks in advance for any pointers. 

Sub CAPSRptformatting()
'
' CAPSRptformatting Macro
'

    Range("F:F,G:G").Select
    Range("G1").Activate
    Selection.Delete Shift:=xlToLeft
    Columns("J:J").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    
    Cells.Find(What:="DEBIT PAYMENT", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Cells(1)).Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Range("A1").Select
     Cells.Find(What:="DEBIT PAYMENT", After:=ActiveCell, LookIn:=xlFormulas, _
         LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Offset(0, -8).Select
    
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select

    Cells.Find(What:="DEBIT PAYMENT", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(-1, 0).Select
    Range(Selection, Cells(1)).Select

    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Selection.Columns(3), Order:=xlAscending
        .SetRange Selection
        .Apply
    End With

    Dim rcell As Range, rng As Range
    For Each rcell In Selection
    If rcell.Value = "BALTIMORE" Then
    If rng Is Nothing Then Set rng = rcell.EntireRow Else: Set rng = Union(rng, rcell.EntireRow)
    End If

        Next rcell
        rng.Select
    'This is where it hangs when "BALTIMORE" is not found
            Selection.Cut
            Cells.Find(What:="THURMONT", After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False).Activate
            ActiveCell.Offset(0, -2).Select
        Selection.Insert
     
    'If rcell.Value Is Nothing Then
    '   Cells.Find(What:="THURMONT", After:=ActiveCell, LookIn:=xlFormulas, _
    '       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    '       MatchCase:=False, SearchFormat:=False).Activate
    '   ActiveCell.Offset(0, -2).Select
    '   Else:
    ' End If
        


End Sub