VBA to find heading, delete, and move onto next heading

Question

I have the following code to find headings (ranging from heading 1-4) with the word "DELETE" in the heading to delete the heading and the text underneath, as well as nested headings. However, it stops after deleting the first set of headings it finds. How can I get it to work through all the headings in the document? Thank you!

Sub deleteheading()
  Dim rngHeading1 As Range
  Set rngHeading1 = GetHeadingBlock("DELETE", wdStyleHeading1)
  If Not rngHeading1 Is Nothing Then rngHeading1.Delete
  
    Dim rngHeading2 As Range
  Set rngHeading2 = GetHeadingBlock("DELETE", wdStyleHeading2)
  If Not rngHeading2 Is Nothing Then rngHeading2.Delete
  
    Dim rngHeading3 As Range
  Set rngHeading3 = GetHeadingBlock("DELETE", wdStyleHeading3)
  If Not rngHeading3 Is Nothing Then rngHeading3.Delete
  
    Dim rngHeading4 As Range
  Set rngHeading4 = GetHeadingBlock("DELETE", wdStyleHeading4)
  If Not rngHeading4 Is Nothing Then rngHeading4.Delete

End Sub
Function GetHeadingBlock(headingText As String, headingStyle As WdBuiltinStyle) As Range
  Dim rngFind As Range
  Set rngFind = ActiveDocument.Content
  With rngFind.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "DELETE"
    .style = headingStyle
    .Replacement.Text = ""
    .Forward = True
    .Format = True
    .Wrap = wdFindStop
    If .Execute Then Set GetHeadingBlock = _
      rngFind.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
  End With
End Function

Answer 1

For example:

Sub DeleteHeadingSpanText()
Application.ScreenUpdating = False
Dim h As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "DELETE"
    .Replacement.Text = ""
    .Format = True
    .Forward = True
    .MatchCase = True
    .MatchWholeWord = True
    .Wrap = wdFindContinue
  End With
  For h = 1 To 9
    .Style = "Heading " & h
    Do While .Find.Execute
      .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Text = vbNullString
    Loop
  Next
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub

Change the 1 & 9 in 'For h = 1 To 9' to define whatever heading levels you want to limit the code's scope to.

Answer 2

This code calls your own function GetHeadingBlock.

Sub DeleteHeading()

  Dim rngHeading    As Range
  Dim i             As WdBuiltinStyle
  
  For i = wdStyleHeading1 To wdStyleHeading4 Step -1
    Do
      Set rngHeading = GetHeadingBlock("DELETE", i)
      If rngHeading Is Nothing Then
          Exit Do
      Else
          rngHeading.Delete
      End If
    Loop
  Next i
End Sub