Paste cells before or after certain rows

Sub FindCopySort()
    Dim ws As Worksheet
    Dim startCellR As Range
    Dim lastRow As Long
    Dim firstNonBlankO As Long
    Dim title2Range As Variant
    Dim result() As Variant
    Dim i As Long, j As Long, k As Long

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet2")
    On Error GoTo 0
    

    Dim startCellRTitle1 As Range
    Set startCellRTitle1 = ws.Columns("R").Find(What:="TITLE1", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellRTitle1 Is Nothing Then Exit Sub

    Set startCellR = ws.Columns("R").Find(What:="TITLE2", LookIn:=xlValues, LookAt:=xlWhole)
    If startCellR Is Nothing Then Exit Sub

    lastRow = ws.Cells(ws.Rows.Count, "R").End(xlUp).Row
    If lastRow < startCellR.Row Then Exit Sub
    
    title2Range = ws.Range(startCellR.Offset(0, -3), ws.Cells(lastRow, "R")).Value
    firstNonBlankO = ws.Columns("O").SpecialCells(xlCellTypeConstants).Cells(1, 1).Row
    If firstNonBlankO = 0 Then Exit Sub
    
    ReDim result(1 To UBound(title2Range, 1), 1 To 4)
    j = 1
    For i = 2 To UBound(title2Range, 1)
        If InStr(1, title2Range(i, 4), "After", vbTextCompare) > 0 Or _
           InStr(1, title2Range(i, 4), "Before", vbTextCompare) > 0 Then
            For k = 1 To 4
                result(j, k) = title2Range(i, k)
            Next k
            j = j + 1
        End If
    Next i
    
    If j > 1 Then
        ws.Rows(firstNonBlankO + 1 & ":" & firstNonBlankO + UBound(result, 1)).Insert Shift:=xlDown
        ws.Range("O" & firstNonBlankO + 1).Resize(UBound(result, 1), 4).Value = result

        Dim sortRng As Range
        Set sortRng = ws.Range(ws.Cells(startCellRTitle1.Row + 1, "O"), ws.Cells(startCellR.Row - 1, "R"))
        sortRng.Sort Key1:=ws.Range("O" & startCellRTitle1.Row + 1), Order1:=xlAscending, Header:=xlNo
        
        Dim delRange As Range
        For Each cell In ws.Range(ws.Cells(startCellRTitle1.Row + 1, "R"), ws.Cells(startCellR.Row - 1, "R"))
            If IsEmpty(cell) Then
                If delRange Is Nothing Then
                    Set delRange = cell
                Else
                    Set delRange = Union(delRange, cell)
                End If
            End If
        Next cell
        If Not delRange Is Nothing Then delRange.EntireRow.Delete
    End If
End Sub