Microsoft Office Forums - View Single Post - [Solved] delete 1 or 2 adjacent duplicate paragraphs, macro

Guessed · 10-31-2018, 05:03 PM

Looping through every subsequent paragraph is a very slow way to go about this. I would use a Find function which is way faster but has the drawback of not working with long paragraphs (I think the limit is 255 characters). I suspect the subtitles are generally short so this might not be a problem for you.

Code:

Sub DeleteDuplicates()
  Dim aRng As Range, aPara As Paragraph, sText As String
  Set aPara = ActiveDocument.Paragraphs.First
  Do While aPara.Range.End <> ActiveDocument.Range.End
    If Len(aPara.Range.Text) > 1 Then
      sText = aPara.Range.Text
      Debug.Print sText
      Set aRng = ActiveDocument.Range
      aRng.Start = aPara.Range.End
      With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = sText
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    End If
    Set aPara = aPara.Next
  Loop
End Sub