Deleting Text between Two Rows with Dynamic Headers - excel

Question

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

Answer 1

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

Answer 2

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

Answer 3

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