.matchwholeword = true not working

[dsrt16]

So I have this code from Allen Wyatt that used to be working just fine, but now it puts even parts of words in red, even though I have set .matchwholeword to true.


So if I have the word "or" on my confusables list, it will put the "or" in the word "color" in red, but I only want the actual word "or" to be in red.

Sub CompareWordList()
    Dim sCheckDoc As String
    Dim docRef As Document
    Dim docCurrent As Document
    Dim wrdRef As Object

    sCheckDoc = "the path to my confusables.doc"
    Set docCurrent = Selection.Document
    Set docRef = Documents.Open(sCheckDoc)
    docCurrent.Activate

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Font.Color = wdColorRed
        .Replacement.Text = "^&"
        .Forward = True
        .Format = True
        .MatchWholeWord = True
        .MatchCase = False
        .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

It used to work, then it didn't. So I tried moving the .matchwholeword = true to earlier in the with selection find section so it came before the replacement font, but then that caused a different error, highlighting the "for each wrdref line."

Any ideas? I am an editor, and I use this to change words to red that are often confused with other words or often need punctuation with them to help me catch additional errors, but it is distracting to have it put parts of words in red.

[macropod]

Apart from anything else, the code you're using is extremely inefficient. Try:

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, i As Long
 'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\FindReplaceList.doc", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
FRList = FRDoc.Range.Text: FRDoc.Close False: Set FRDoc = Nothing
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Replacement.Font.Color = wdColorRed
  .Replacement.Text = "^&"
  .Forward = True
  .Format = True
  .MatchWholeWord = True
  'Process each entry from the source list.
  For i = 0 To UBound(Split(FRList, vbCr)) - 1
    .Text = Split(FRList, vbCr)(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

The above code assumes the strings to be found are separated by paragraph breaks. This allows you to process multi-word strings. If you're using spaces instead, use:

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, i As Long
 'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\FindReplaceList.doc", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
FRList = FRDoc.Range.Text: FRDoc.Close False: Set FRDoc = Nothing
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Replacement.Font.Color = wdColorRed
  .Replacement.Text = "^&"
  .Forward = True
  .Format = True
  .MatchWholeWord = True
  'Process each entry from the source list.
  For i = 0 To UBound(Split(FRList, " "))
    .Text = Split(FRList, " ")(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub