Option Explicit 
Dim strFnd As String 

Sub HilightDocumentDuplicates() 
     ' Turn Off Screen Updating
    Application.ScreenUpdating = False 
    Dim strFolder As String, strFile As String, wdDoc As Document 
    Dim StrTmp As String, i As Long, TrkStatus  As Boolean, bFnd As Boolean 
     'Prompt for the folder to process
    strFolder = GetFolder 
    If strFolder = "" Then Exit Sub 
    strFile = Dir(strFolder & "\*.doc", vbNormal) 
     'Process each file in the folder
    While strFile <> "" 
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _ 
        AddtorecentFiles:=False, Visible:=False) 
         ' Store current Track Changes status, then switch off
        TrkStatus = wdDoc.TrackRevisions 
        wdDoc.TrackRevisions = False 
         'Compile the Find concordance
        Call ConcordanceBuilder(wdDoc) 
         'Process all words in the concordance
        For i = 1 To UBound(Split(strFnd, " ")) 
            StrTmp = Split(strFnd, " ")(i) 
            bFnd = False 
            With wdDoc.Range 
                With .Find 
                    .ClearFormatting 
                     'Look for duplicated words only
                    .Text = StrTmp 
                    .Replacement.Text = "" 
                    .Forward = True 
                    .Wrap = wdFindStop 
                    .Format = False 
                    .MatchCase = False 
                    .MatchWholeWord = True 
                    .MatchWildcards = False 
                    .MatchSoundsLike = False 
                    .MatchAllWordForms = False 
                    .Execute 
                End With 
                Do While .Find.Found 
                    If bFnd = True Then 
                        .Duplicate.HighlightColorIndex = wdBrightGreen 
                    End If 
                    bFnd = True 
                    .Collapse wdCollapseEnd 
                    .Find.Execute 
                Loop 
            End With 
        Next 
         ' Restore original Track Changes status
        wdDoc.TrackRevisions = TrkStatus 
        wdDoc.Close SaveChanges:=True 
        strFile = Dir() 
    Wend 
    Set wdDoc = Nothing 
     ' Restore Screen Updating
    Application.ScreenUpdating = True 
End Sub 

Function GetFolder() As String 
    Dim oFolder As Object 
    GetFolder = "" 
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) 
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path 
    Set oFolder = Nothing 
End Function
 
Sub ConcordanceBuilder(wdDoc As Document) 
    Dim StrIn As String, StrTmp As String, StrIncl As String, StrExcl As String 
    Dim i As Long, j As Long, k As Long 
     'Define the exlusions list
    StrExcl = "a,am,and,are,as,at,b,be,but,by,c,can,cm,d,did,do,does,e,eg,en,eq,etc,f,for," & _ 
    "g,get,go,got,h,has,have,he,her,him,how,i,ie,if,in,into,is,it,its,j,k,l,m," & _ 
    "me,mi,mm,my,n,na,nb,no,not,o,of,off,ok,on,one,or,our,out,p,q,r,re,s,she,so," & _ 
    "t,the,their,them,they,t,to,u,v,w,was,we,were,who,will,would,x,y,yd,you,your,z" 
     'Define an inclusions list for terms that otherwise don't survive the initial cleanup
    StrIncl = "c/c++,c#" 
    With wdDoc 
         'Get the document's text
        StrIn = .Content.Text 
         'Strip out unwanted charactersFor i = 1 To 255
           Select Case i
             Case 1 To 31, 33 To 64, 91 To 96, 123 To 144, 147 To 191, 247
             Do While InStr(StrIn, Chr(i)) > 0
               StrIn = Replace(StrIn, Chr(i), " ")
             Loop
           End Select
         Next
         'Convert smart single quotes to plain single quotes & delete any at the start/end of a word
        StrIn = Replace(Replace(Replace(Replace(StrIn, Chr(145), "'"), Chr(146), "'"), "' ", " "), " '", " ") 
         'Convert to lowercase
        StrIn = " " & LCase(Trim(StrIn)) & " " 
         'Process the exclusions list
        For i = 0 To UBound(Split(StrExcl, ","))
            While InStr(StrIn, " " & Split(StrExcl, ",")(i) & " ") > 0
              StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
            Wend
          Next
         'Restore the specified inclusions
        StrIn = Replace(StrIncl, ",", " ") & StrIn 
         'Clean up any duplicate spaces
        While InStr(StrIn, "  ") > 0 
            StrIn = Replace(StrIn, "  ", " ") 
        Wend 
        StrIn = " " & Trim(StrIn) & " " 
        j = UBound(Split(StrIn, " ")) 
        For i = 1 To j 
          StrTmp = Split(StrIn, " ")(1) 
           'Find how many occurences of each word there are in the document
          While InStr(StrIn, " " & StrTmp & " ") > 0 
              StrIn = Replace(StrIn, " " & StrTmp & " ", " ") 
          Wend 
          k = j - UBound(Split(StrIn, " ")) 
           'If there's more than one occurence, add the word to our Find list
          If k > 1 Then 
              strFnd = strFnd & " " & StrTmp 
          End If 
          j = UBound(Split(StrIn, " ")) 
        Next 
    End With 
End Sub