Find and delete duplicate word headings

[gmaxey]

Not well thought out but something like this:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim lngIndex As Long
Dim oRng As Word.Range
Dim oCol As New Collection
  For lngIndex = 1 To ActiveDocument.Paragraphs.Count
    If ActiveDocument.Paragraphs(lngIndex).Range.Style = "Heading 1" Then
      On Error GoTo flag_Duplicate
      oCol.Add ActiveDocument.Paragraphs(lngIndex).Range, ActiveDocument.Paragraphs(lngIndex).Range
    End If
  Next lngIndex
  MsgBox "There are " & oCol.Count & " unique Heading 1"
  If MsgBox("Do you want to delete duplicates?", vbYesNo, "Delete Dups") = vbYes Then
    For lngIndex = ActiveDocument.Paragraphs.Count To 1 Step -1
      If VBA.Right(ActiveDocument.Paragraphs(lngIndex).Range.Text, 14) = " (Duplicated)" & vbCr Then
        ActiveDocument.Paragraphs(lngIndex).Range.Delete
      End If
    Next lngIndex
  End If
lbl_Exit:
  Exit Sub
flag_Duplicate:
  Set oRng = ActiveDocument.Paragraphs(lngIndex).Range
  oRng.MoveEnd wdCharacter, -1
  oRng.InsertAfter " (Duplicated)"
  Resume Next
End Sub