Sub CompareWordList() 
    Dim sCheckDoc As String 
    Dim docRef As Document 
    Dim docCurrent As Document 
    Dim wrdRef As Object 
    sCheckDoc = "C:\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 
    For Each wrdRef In docRef.Words 
        If Asc(Left(wrdRef, 1)) > 32 Then 
            With Selection.Find 
                .Wrap = wdFindContinue 
                .Text = wrdRef 
                .Execute Replace:=wdReplaceAll 
            End With 
        End If 
    Next wrdRef 
    docRef.Close 
    docCurrent.Activate 
End Sub