Deleting Text between Two Rows with Dynamic Headers-CodePudding

I am trying to delete text between two rows that occur multiple times in my Excel spreadsheet. The number of rows in between the text headers varies each time. One of the row headers remains the same, but the first row header will change each time, from Property A to Property B to Property C. I found an answer that helps me fairly well, but how do I use a wildcard symbol to make my starting string be "Property:*"?

Dim strStart As String, strEnd As String
Dim DELETEMODE As Boolean
Dim DelRng As Range
    strStart = "Property: A"
    strEnd = "Total"

DELETEMODE = False
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 = strStart Then DELETEMODE = True
Next r

'Delete the Range compiled from above
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete xlShiftUp

CodePudding user response：

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

CodePudding user response：

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