（这个问题建立在一个已经存在并已解决的问题的基础上，可以在这里找到：用于突出显示多个单词的 Microsoft Word 宏）
1.目标是在全文Word文档中仅突出显示字符串中单词上的ending单词，并标记那些整个单词（而不仅仅是相应的部分）。这个想法是通过突出显示经常错误使用的单词来简化语法纠正。
例如，字符串（“more”、“ever”）应用于以下文本：
而且，永远如此。每一天，永远。
应标记（整个）第一个和最后一个单词，而不是中间的单词。
2.我列出的术语列表多达 800 个单词。在下面的代码中插入此代码会出现错误“字符串太长”。唯一的解决方案可能是使用单独的文档并将代码引用到该文档。关于如何最优雅地解决这个问题有什么想法吗？如果代码内解决方案不理想，那么单独的文档必须采用什么格式？
3.执行宏后，如何显示消息框，通知您有多少单词已突出显示（或没有突出显示）？在上面的例子中：“找到了两个单词”。
非常感谢您的帮助。
威廉
这是已经提供的代码，可能是一个好的开始：
Sub highlightWords()
Dim range As range
TargetList = Array("lastwordpart1", "lastwordpart2", "lastwordpart3") ' list of terms to find is too long for this string…
For Each Target In TargetList
Set range = ActiveDocument.range
With range.Find
.Text = Target
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute(Forward:=True) = True
range.HighlightColorIndex = wdGray25
Loop
End With
Next
End Sub
受到其他问题和答案的启发，我成功创建了一个宏来完成我想要的大部分操作。最后，我将单词列表保存在 Word STARTUP 文件夹中的宏模板 (.dotm) 中。宏将此文件引用为目标列表。
本质上，宏使用带有通配符的查找和替换功能。目标列表中的单词已更改，以使其发挥作用。下面是一个示例：要查找单词“never”，请将该术语修改为 [N,n]ever>。 > 表示该单词在搜索词之后结束。例如，“Nevermore”没有被标记。这是故意的。
这仍然存在三个问题：
1. 通配符区分大小写。这使得很难找到带有或不带有大写字母的单词。我的解决方法是只查找首字母大写和不带大写的单词。完全用大写字母书写的单词将不会被发现。这是一个缺陷，但我认为完全用大写字母书写的单词在全文中大多很少见。这解释了搜索词 [N,n]ever 中的 [N,n]。为了您的利益，将每个字母放在括号中对于搜索引擎来说太困难了，它在尝试时给出了错误。
无论情况如何，欢迎提出如何实现这一目标的想法。
2. 我没能突出显示整个单词。有一个方法，但它要求我将单词的第一个字母替换为<[!^09-^13 ]@. In the example above, this would be <[!^09-^13 ]@ever>。它会标记包含“never”的整个单词，例如“whenever”，但它也会标记“bever”、“clever”等单词，这是不需要的。我决定不使用这个解决方案，因为它导致了太多不需要的点击。
欢迎提出有关如何标记整个单词而不必从初始搜索词中删除字母的想法。
3. 我在这个平台上找到了其他来源，了解如何提供一个消息框来计算突出显示的单词数（例如：使用 VBA 查找、突出显示并列出文档中找到的单词实例的数量），但我对它的理解不够好来实施它。所以我最终得到了一个简单的消息框，告诉您宏何时完成。
没有它我也可以生活，但如果不是太麻烦的话，欢迎提出建议。
这是最终的代码。
Sub Highlighter()
Selection.HomeKey Unit:=wdStory
Dim FRDoc As Document, FRList() As String, i As Long, aRng As Range
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdTurquoise
Set FRDoc = Documents.Open(Application.StartupPath & "\Highlighter.dotm",
ReadOnly:=True, Addtorecentfiles:=False, Visible:=False)
FRList = Split(FRDoc.Range.Text, vbCr)
FRDoc.Close False
Set FRDoc = Nothing
Set aRng = Selection.Range
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.Wrap = wdFindStop
.Replacement.Text = "^&"
.Replacement.Highlight = True
For i = 0 To UBound(FRList)
If Trim(FRList(i)) <> "" Then
.Text = Trim(FRList(i))
.Execute Replace:=wdReplaceAll
End If
Next
End With
MsgBox "Job done."
End Sub