WordVBA將未找到的內容標識為已找到-有解無憂

我有一個運行良好的 Word 宏，除了一個我找不到的錯誤。此代碼獲取一個 Word 檔案，并突出顯示出現在第二個單詞串列檔案（每段一個單詞）中的整個單詞的每次出現，過濾相同的大小寫和整個單詞。然后它突出顯示它找到的單詞串列檔案中的任何術語。這似乎作業正常，只是它在確定找到的內容時忽略了 .MatchWholeWord 。例如，如果目標檔案包含“McHeath”或“Heathcliff”，則它不會在目標中突出顯示，而是在單詞串列檔案中突出顯示“Heath”，就好像它被定位一樣。是否有替代 .found 來確定是否進行了替換？還是我需要使用 .Execute Replace:=wdReplaceAll 以外的方法并將突出顯示的命令放在那里？

謝謝！

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

uj5u.com熱心網友回復：

我能夠通過對查找文本使用全字通配符搜索來解決此問題。我本來希望 MatchWholeWord 具有相同的效果，并且必須進一步研究。

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

uj5u.com熱心網友回復：

我不是一個 Word VBA 編碼器，但這是你的代碼的一個稍微簡化的版本，它對我有用，正如你所描述的那樣。

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

uj5u.com熱心網友回復：

鑒于這Find.Execute是一個布爾函式，因此無需使用該.Found屬性。

通常，.Found將在回圈中使用，Find.Execute使用時不帶任何引數，以便可以在每次匹配時執行代碼。有一些報告.Found是不可靠的，所以最好.Execute改用。

使用Selection也是一個壞習慣，你最好改掉

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

轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/429213.html

標籤：vba ms-word 强调查找替换

上一篇：VBA-粘貼后標簽丟失文本

下一篇：查找活動單元格所在列的范圍