CompareWordList

gistfile1.vb

Sub CompareWordList()
'
' CompareWordList Macro
' Andrew Crook 2012
' Based on - Highlight Words from a Word List 
' http://word.tips.net/T000502_Highlight_Words_from_a_Word_List.html
'
Dim sCheckDoc As String
    Dim docRef As Document
    Dim docCurrent As Document
    Dim wrdRef As String
    
    Dim objFSO As Object
    Dim objShell As Object
    Dim objFolder As Object
    Dim objFolderItem As Object
    
    Dim wordcount As Integer
    Dim icount As Integer
        
    Const MY_DOCUMENTS = &H5&
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    
    Set objFolder = objShell.Namespace(MY_DOCUMENTS)
    Set objFolderItem = objFolder.Self
    MyDocuments = objFolderItem.Path
    
    ' .docx for mordern versions of word .doc for old.
    sCheckDoc = MyDocuments + "\checklist.doc"
    Set docCurrent = Selection.Document
    Set docRef = Documents.Open(sCheckDoc)
    docCurrent.Activate

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = True
        .Replacement.Text = "^&"
        .Forward = True
        .Format = True
        .MatchWholeWord = True
        .MatchCase = True
        .MatchWildcards = False
    End With

    wordcount = docRef.Words.Count
    
    For icount = 1 To wordcount
        wrdRef = Trim(docRef.Words(icount).Text)
        If Asc(Left(wrdRef, 1)) > 32 Then
        StatusBar = "Comparing : '" + wrdRef + "' | word " + Str(icount) + " out of " + Str(wordcount)
            With Selection.Find
                .Wrap = wdFindContinue
                .Text = wrdRef
                .Execute Replace:=wdReplaceAll
            End With
        End If
        DoEvents
    Next icount


    docRef.Close
    docCurrent.Activate

End Sub

updated version doesn't freeze word when looping and shows progress in status bar of the documents window.