[SOLVED] Delete Duplicate words with an efficient VBA Macro from document


I have this macro that compare each word with other and check if that is the duplicate if yes then delete it, however it works really great for 1 to 4 pages with a time of at-most 5minutes.
But for the document of 50 or 100 pages it took me a decade to run it.

I am in need of modification Or a new idea to compare and delete duplicates with more efficient code and less time. How should I do?

Sub Delete_Duplicates()
    Dim AD As Range
    Dim F As Range
    Dim i As Long
    Set AD = ActiveDocument.Range
    Z = AD.Words.Count
    y = 1
    For i = Z To 1 Step -1
        y = y + 1
        Set F = AD.Words(i)
        On Error Resume Next
        Set s = AD.Words(i - 1)
        If Trim(AD.Words(i - 1)) = "," Then Set s = AD.Words(i - 2): Set c = AD.Words(i - 1)
        If Err.Number > 0 Then Exit Sub
        If Not F.Text = Chr(13) And UCase(Trim(F.Text)) = UCase(Trim(s.Text)) Then
                F.Text = ""
            If Not c Is Nothing Then c.Text = " ": Set c = Nothing
        End If
            If Not c Is Nothing Then Set c = Nothing
    On Error Resume Next
    Call ProgressBar.Progress(y / Z * 100, True) '<<-- Progress Bar
    On Error GoTo 0
End Sub

enter image description here


You might try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .Replacement.Text = "\1"
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "([A-Za-z0-9'’]@)[, ]@\1"
    Do While .Found = True
      .Execute Replace:=wdReplaceAll
    .Text = "([A-Za-z0-9'’]@[, ]@[A-Za-z0-9'’]@)[, ]@\1"
    Do While .Found = True
      .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

Answered By – macropod

Answer Checked By – Clifford M. (BugsFixing Volunteer)

Leave a Reply

Your email address will not be published. Required fields are marked *