Word VBA is identifying unfound content as found-CodePudding

I have a Word macro that works fine except for one bug that I cannot locate. This code takes a Word file and highlights every appearance of a whole word appearing in a second word list document (one word per paragraph) filtering for same case and whole words only. It then highlights any terms in the word list document that it found. This appears to work fine except that it is ignoring .MatchWholeWord when it determines what is found. For example, if a target document includes "McHeath" or "Heathcliff" it highlights neither in the target but highlights "Heath" in the word list document as though it were located. Is there an alternate to .found to determine if a replacement was made? Or do I need to use a method other than .Execute Replace:=wdReplaceAll and put the highlighting commands in there?

Thanks!

Sub HighlightFromWordList()
    
    Dim NumberOfWords As Integer
    Dim iLoop As Integer
    Dim iPosition As Integer
    Dim aTerms() As String
    Dim sSel As String
    Dim docSource As Document
    Dim docTarget As Document
    Dim aFound() As Boolean
    Dim iWordCount As Long
    Dim bTrackRevFlag As Boolean
    Const sDialogTitle As String = "Highlight from Word List"
    Const iHighlightColor As Integer = wdGray25
    
    On Error GoTo Err_Msg

    Application.ScreenUpdating = False
    Set docTarget = ActiveDocument
    bTrackRevFlag = docTarget.TrackRevisions
    If bTrackRevFlag = True Then docTarget.TrackRevisions = False
    Options.DefaultHighlightColorIndex = iHighlightColor
    ChangeFileOpenDirectory ActiveDocument.Path
    With Dialogs(wdDialogFileOpen)
        If .Display Then
            If .Name <> "" Then
                Set docSource = Documents.Open(.Name, Visible:=True)
            End If
            Else
                GoTo Macroend
        End If
    End With
    Documents(docSource).Activate
    Selection.WholeStory
    NumberOfWords = ActiveDocument.Range.Paragraphs.Count
    Selection.End = Selection.End - 1
    ReDim aTerms(NumberOfWords) As String
    aTerms = Split(Selection.Range, vbCr)
    
    ReDim aFound(NumberOfWords) As Boolean
    For a = 0 To NumberOfWords
        aFound(a) = False
    Next a
    Documents(docTarget).Activate
    Selection.HomeKey Unit:=wdStory
    For i = 0 To UBound(aTerms)
        sSel = aTerms(i)
        With Selection.Find
            .Text = sSel
            .ClearFormatting
            .Replacement.ClearFormatting
            .Replacement.Text = sSel '"^&"
            .Replacement.Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = True
            .MatchWholeWord = True
            .Execute Replace:=wdReplaceAll
            If .Found Then aFound(i) = True
        End With
    Next i
    Documents(docSource).Activate
    For a = 0 To NumberOfWords
        If aFound(a) = True Then
            Documents(docSource).Paragraphs(a   1).Range.Select
            Selection.Range.HighlightColorIndex = iHighlightColor
        End If
    Next a
    Selection.HomeKey Unit:=wdStory
    Documents(docSource).Activate
    
Macroend:
    Application.ScreenUpdating = True
    docTarget.TrackRevisions = bTrackRevFlag
    Exit Sub

Err_Msg:
    Application.ScreenUpdating = True
    docTarget.TrackRevisions = bTrackRevFlag
    If err.Number = 4172 Then
        ChangeFileOpenDirectory Options.DefaultFilePath(wdDocumentsPath)
        Resume Next
        Else
        MsgBox "The macro has encountered an error." & vbCrLf & err.Number & ": " & err.description, vbCritical, sDialogTitle
        MsgBox "The last processed term was " & sSel, vbCritical, sDialogTitle
    End If
End Sub

CodePudding user response：

I'm not much of a Word VBA coder but this is a slightly simplified version of your code which works for me as you described you wanted it to.

Sub HighlightFromWordList()
    
    Const iHighlightColor As Integer = wdGray25
    
    Dim txt As String
    Dim docSource As Document
    Dim docTarget As Document
    Dim i As Long, paras As Paragraphs
    
    Set docSource = ThisDocument
    Set docTarget = Documents("Document2")
    
    Set paras = docSource.Range.Paragraphs 'all search terms
    
    Options.DefaultHighlightColorIndex = iHighlightColor  'edited
    
    For i = 1 To paras.Count
        txt = paras(i).Range.Text     'search term
        txt = Left(txt, Len(txt) - 1) 'trim paragraph marker
        With docTarget.Range.Find
            .Text = txt
            .ClearFormatting
            With .Replacement
                .ClearFormatting
                .Text = txt
                .Highlight = True
            End With
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = True
            .MatchWholeWord = True
            .Execute Replace:=wdReplaceAll
            If .Found Then
                paras(i).Range.HighlightColorIndex = iHighlightColor
            End If
        End With
    Next i
End Sub

CodePudding user response：

I was able to resolve this by using a whole-word wildcard search for the find text. I would have expected MatchWholeWord to have the same effect, and will have to research this further.

Sub HighlightFromWordList()
    
    Dim NumberOfWords As Integer
    Dim iLoop As Integer
    Dim iPosition As Integer
    Dim aTerms() As String
    Dim sSel As String
    Dim docSource As Document
    Dim docTarget As Document
    Dim aFound() As Boolean
    Dim iWordCount As Long
    Dim bTrackRevFlag As Boolean
    Const sDialogTitle As String = "Highlight from Word List"
    Const iHighlightColor As Integer = wdGray25
    
    On Error GoTo Err_Msg

    Application.ScreenUpdating = False
    Set docTarget = ActiveDocument
    bTrackRevFlag = docTarget.TrackRevisions
    If bTrackRevFlag = True Then docTarget.TrackRevisions = False
    Options.DefaultHighlightColorIndex = iHighlightColor
    ChangeFileOpenDirectory ActiveDocument.Path
    With Dialogs(wdDialogFileOpen)
        If .Display Then
            If .Name <> "" Then
                Set docSource = Documents.Open(.Name, Visible:=True)
            End If
            Else
                GoTo Macroend
        End If
    End With
    Documents(docSource).Activate
    Selection.WholeStory
    NumberOfWords = ActiveDocument.Range.Paragraphs.Count
    Selection.End = Selection.End - 1
    ReDim aTerms(NumberOfWords) As String
    aTerms = Split(Selection.Range, vbCr)
    
    ReDim aFound(NumberOfWords) As Boolean
    For a = 0 To NumberOfWords
        aFound(a) = False
    Next a
    Documents(docTarget).Activate
    Selection.HomeKey Unit:=wdStory
    For i = 0 To UBound(aTerms)
        sSel = aTerms(i)
        With Selection.Find
            .Text = "<" & sSel & ">"
            .ClearFormatting
            .Replacement.ClearFormatting
            .Replacement.Text = sSel
            .Replacement.Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = True
            .MatchWholeWord = True
            .Match Wildcards = True
            .Execute Replace:=wdReplaceAll
            If .Found Then aFound(i) = True
        End With
    Next i
    Documents(docSource).Activate
    For a = 0 To NumberOfWords
        If aFound(a) = True Then
            Documents(docSource).Paragraphs(a   1).Range.Select
            Selection.Range.HighlightColorIndex = iHighlightColor
        End If
    Next a
    Selection.HomeKey Unit:=wdStory
    Documents(docSource).Activate
    
Macroend:
    Application.ScreenUpdating = True
    docTarget.TrackRevisions = bTrackRevFlag
    Exit Sub

Err_Msg:
    Application.ScreenUpdating = True
    docTarget.TrackRevisions = bTrackRevFlag
    If err.Number = 4172 Then
        ChangeFileOpenDirectory Options.DefaultFilePath(wdDocumentsPath)
        Resume Next
        Else
        MsgBox "The macro has encountered an error." & vbCrLf & err.Number & ": " & err.description, vbCritical, sDialogTitle
        MsgBox "The last processed term was " & sSel, vbCritical, sDialogTitle
    End If
End Sub