I refer to a code from :https://www.datanumen.com/blogs/quickly-find-delete-paragraphs-containing-specific-texts-word-document/

However, I can only delete the heading rather than the whole paragraph(heading content). I've tried several methods but it still not work...please help me with this, thanks!

Sub DeleteParagraphsContainingSpecificTexts()
  Dim strFindTexts As String
  Dim strButtonValue As String
  Dim nSplitItem As Long
  Dim objDoc As Document

  strFindTexts = InputBox("Enter texts to be found here, and use commas to separate them: ", "Texts to be found")
  nSplitItem = UBound(Split(strFindTexts, ","))
  With Selection
    .HomeKey Unit:=wdStory
 
    ' Find the entered texts one by one.
    For nSplitItem = 0 To nSplitItem


      ' Find text in Heading1
    
      With Selection.Find
        .ClearFormatting
        .Text = Split(strFindTexts, ",")(nSplitItem)
        .Style = wdStyleHeading1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWholeWord = False 
        .MatchCase = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchAllWordForms = False
        .Execute
      End With

      Do While .Find.Found = True
        ' Expand the selection to the entire paragraph.
        Selection.Expand Unit:=wdParagraph
        strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
        If strButtonValue = vbYes Then
          Selection.Delete
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop


    ' Find text in Heading2
    
      With Selection.Find
        .ClearFormatting
        .Text = Split(strFindTexts, ",")(nSplitItem)
        .Style = wdStyleHeading2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWholeWord = False
        .MatchCase = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchAllWordForms = False
        .Execute
      End With

      Do While .Find.Found = True
        ' Expand the selection to the entire paragraph.
        Selection.Expand Unit:=wdParagraph
        strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
        If strButtonValue = vbYes Then
          Selection.Delete
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      
      ' Find text in Heading3
      
      With Selection.Find
        .ClearFormatting
        .Text = Split(strFindTexts, ",")(nSplitItem)
        .Style = wdStyleHeading3
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWholeWord = False
        .MatchCase = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchAllWordForms = False
        .Execute
      End With

      Do While .Find.Found = True
        ' Expand the selection to the entire paragraph.
        Selection.Expand Unit:=wdParagraph
        strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
        If strButtonValue = vbYes Then
          Selection.Delete
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      
      
    Next
  End With

  MsgBox ("Word has finished finding all entered texts.")
  Set objDoc = Nothing

End Sub

CodePudding user response：

The problem isn't the code, it is your understanding of what a paragraph is. In your example each line of text is a paragraph.

From your description what you are trying to do is delete blocks of content under a heading containing a keyword, or in Word terminology "a Heading Level". The following code should work for you:

Sub DeleteParagraphsContainingSpecificTexts()
  Dim strFindTexts As String
  Dim strButtonValue As String
  Dim nSplitItem As Long
  Dim objDoc As Document

  strFindTexts = InputBox("Enter texts to be found here, and use commas to separate them: ", "Texts to be found")
  nSplitItem = UBound(Split(strFindTexts, ","))
 
    ' Find the entered texts one by one.
    For nSplitItem = 0 To nSplitItem
        DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading1
        DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading2
        DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading3
    Next
End Sub

Public Sub DeleteHeadingBlock(ByVal headingText As String, headingStyle As WdBuiltinStyle)
    Dim hdgBlock As Range
    With ActiveDocument.Content
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = headingText
            .Style = headingStyle
            .Replacement.Text = ""
            .Forward = True
            .Format = True
            .Wrap = wdFindStop
        End With
        Do While .Find.Execute
            Set hdgBlock = .GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
            hdgBlock.Delete
        Loop
    End With
End Sub