Highlighting found words: unfound content is indicated found-CodePudding

I have a Word macro that takes a Word file and highlights every appearance of a whole word appearing in a 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.

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 alternative to .found to determine if a replacement was made?
Do I need to use a method other than .Execute Replace:=wdReplaceAll and put the highlighting commands there?

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：

Given that Find.Execute is a boolean function there is no need to use the .Found property.

Typically, .Found would be used in a loop, with Find.Execute used without any parameters, so that code can be executed on each match. There have been some reports that .Found is unreliable so it is best to use .Execute instead.

The use of Selection is also a bad habit you would do well to break

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
    Dim sourceText As Range
    NumberOfWords = docSource.Range.Paragraphs.Count
    Set sourceText = docSource.Content
    sourceText.MoveEnd wdCharacter, -1
    ReDim aTerms(NumberOfWords) As String
    aTerms = Split(sourceText.Text, vbCr)
    
    Dim a As Long
    ReDim aFound(NumberOfWords) As Boolean
    For a = 0 To NumberOfWords
        aFound(a) = False
    Next a
    Dim i As Long
    For i = 0 To UBound(aTerms)
        sSel = aTerms(i)
        With docTarget.Content.Find
            .Text = "<" & sSel & ">"
            .ClearFormatting
            .Replacement.ClearFormatting
            .Replacement.Text = sSel
            .Replacement.Highlight = True
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = True
            .MatchWholeWord = True
            .MatchWildcards = True
            aFound(i) = .Execute(Replace:=wdReplaceAll)
        End With
    Next i
    For a = 0 To NumberOfWords
        If aFound(a) = True Then _
            docSource.Paragraphs(a   1).Range.HighlightColorIndex = iHighlightColor
    Next a
    
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 was able to resolve this by using a whole-word wildcard search for the find text. This doesn't address the issue of why .matchWholeWord doesn't do exactly the same thing, however.

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
            .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

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