突出显示已找到的单词:未找到的内容表示已找到

Question

我有一个Word宏，它接受一个Word文件，并突出显示单词列表文档中出现的所有单词(每段一个单词(，只过滤相同大小写和完整单词。然后，它会突出显示它在单词列表文档中找到的任何术语。

当它确定找到什么时，它忽略.MatchWholeWord。

例如，如果目标文档包括"；McHeath"；或"；希斯克利夫；它既不在目标中突出显示；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

Answer 1

假定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

Answer 2

我能够通过对查找文本使用全词通配符搜索来解决这个问题。然而，这并没有解决.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
.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

Answer 3

我不是一个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