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() '***********' 'By 'MBA '***********' 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 Next Beep End Sub
You might try something along the lines of:
Sub Demo() Application.ScreenUpdating = False With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Replacement.Text = "\1" .Forward = True .Wrap = wdFindContinue .MatchWildcards = True .Text = "([A-Za-z0-9'’]@)[, ]@\1" .Execute Do While .Found = True .Execute Replace:=wdReplaceAll Loop .Text = "([A-Za-z0-9'’]@[, ]@[A-Za-z0-9'’]@)[, ]@\1" .Execute Do While .Found = True .Execute Replace:=wdReplaceAll Loop End With End With Application.ScreenUpdating = True End Sub
Answered By – macropod
Answer Checked By – Clifford M. (BugsFixing Volunteer)