Deleting Text between Two Rows with Dynamic Headers

Quick example with regard to comments on using find():

Sub test()
    With Sheets(1)
        Dim lastRow As Long:  lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim i As Long
        For i = 1 To lastRow
            Dim firstFoundCell As Range:  Set firstFoundCell = .Range(.Cells(i, 1), .Cells(lastRow, 1)).Find(what:="Property: ", LookIn:=xlValues, lookat:=xlPart)
            If firstFoundCell Is Nothing Then
                Exit For
            Else
                Dim secondFoundCell As Range:  Set secondFoundCell = .Range(.Cells(firstFoundCell.Row + 1, 1), .Cells(lastRow, 1)).Find(what:="Property: ", LookIn:=xlValues, lookat:=xlPart)
                If secondFoundCell Is Nothing Then
                    Exit For
                Else
                    Dim deleteRange As Range
                    If deleteRange Is Nothing Then
                        Set deleteRange = .Range(.Rows(firstFoundCell.Row + 1), .Rows(secondFoundCell.Row - 1))
                    Else
                        Set deleteRange = Union(deleteRange, .Range(.Rows(firstFoundCell.Row + 1), .Rows(secondFoundCell.Row - 1)))
                    End If
                    i = firstFoundCell.Row + 1
                    Set firstFoundCell = Nothing
                    Set secondFoundCell = Nothing
                End If
            End If
        Next i
        If Not deleteRange Is Nothing Then deleteRange.Delete
    End With
End Sub

Solution based on filtering followed by processing of visible cell coordinates. Will not work if there is a mismatch between "Property - Total" pairs

Sub DelGaps()
    With ActiveSheet
        Set Rng = Intersect(.Columns("A"), .UsedRange)
        Rng.AutoFilter Field:=1, Criteria1:="=Property*", Operator:=xlOr, Criteria2:="=Total"
        
        On Error GoTo out
        Set Rng = Rng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ReDim a(0 To Rng.Count - 1)
        For Each cl In Rng
            a(i) = cl.Row: i = i + 1
        Next
        
        For i = UBound(a) To 0 Step -2
            rfrom = a(i - 1) + 1
            rto = a(i) - 1
            If rto > rfrom Then _
                .Rows(rfrom & ":" & rto).Interior.Color = vbRed 'Delete
        Next
    
out:
        .AutoFilterMode = False
    End With
End Sub

Red rows will be deleted

Delete Between Headers and Totals

A Quick Fix

• When considering using wild cards, the Like operator should immediately come to mind.
• ' *** indicates the changes.

Sub QuickFix()

    Dim dT As Double: dT = Timer

    Const strStart As String = "Property: *" ' ***
    Const strEnd As String = "Total" ' ***
    
    Dim DelRng As Range
    Dim r As Long ' ***
    Dim DELETEMODE As Boolean
    
    For r = 1 To Range("A" & Rows.Count).End(xlUp).Row  'first to last used row
        
        If Range("A" & r).Value = strEnd Then DELETEMODE = False
        
        If DELETEMODE Then
            'Create a Delete Range that will be used at the end
            If DelRng Is Nothing Then
                Set DelRng = Range("A" & r)
            Else
                Set DelRng = Application.Union(DelRng, Range("A" & r))
            End If
        End If
        
        If Range("A" & r).Value Like strStart Then DELETEMODE = True ' ***
    
    Next r
    
    'Delete the Range compiled from above
    If Not DelRng Is Nothing Then DelRng.EntireRow.Delete xlShiftUp

    Debug.Print Timer - dT

End Sub

• There are a few issues with this code.
• Firstly, it is a little bit slow which is covered in the Improvement in detail and mainly consists of combining the appropriate ranges (not each cell) into the Delete range.
• Secondly, let's focus on what will be deleted if your data accidentally has missing Totals. Consider the following extreme-case image:

• What should be deleted? Here is what happens after using your amended code.

• Here is what I would like to happen covered in the Improvement.

• In a nutshell, all Properties should stay alive and rows should only be deleted above the Totals if there previously was a Property row detected. In this case, only row 18 was deleted.

The Improvement

Sub DeleteBetweenHeaders()
    
    Dim dT As Double: dT = Timer
    
    Const strStart As String = "Property: *"
    Const strEnd As String = "Total"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range
    Set rg = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
    
    Dim drg As Range
    Dim cell As Range
    Dim r As Long
    Dim fr As Long
    Dim lr As Long
    
    For Each cell In rg.Cells
        r = r + 1
        If cell.Value Like strStart Then
            fr = r + 1 ' write the next row to the first row variable
        ElseIf cell.Value = strEnd Then
            lr = r - 1 ' write the previous row to the last row variable
            If fr > 0 Then ' the first row is set
                If lr >= fr Then ' there is a gap
                    If drg Is Nothing Then
                        Set drg = rg.Cells(fr).Resize(lr - fr + 1)
                    Else
                        Set drg = Union(drg, rg.Cells(fr).Resize(lr - fr + 1))
                    End If
                'Else ' lr < fr i.e. there is no gap; do nothing
                End If
                fr = 0 ' reset the first row
            'Else ' there is no first row yet; do nothing
            End If
        End If
    Next cell
    
    If Not drg Is Nothing Then drg.EntireRow.Delete xlShiftUp

    Debug.Print Timer - dT

End Sub