Word宏可查找多个关键字并将注释添加到相应的关键字

问题描述

我需要编写宏的帮助，该宏可搜索大型文档（超过100页）以找到某些关键字，并在找到的每个实例中插入注释。我想引用数百个关键字，但为简单起见，在此示例中，我使用了三个关键字。

找到的关键字X实例将有特定的注释。
找到的关键字Y实例将有特定的注释。
找到的关键字Z实例将有特定的注释...等等。

例如：
关键字X在Word文档中出现19次。为了使事情复杂化，关键字X可以是同一单词的变体形式（例如，工作，工作，工作，工作）
关键字Y在Word文档中出现7次。
关键字Z在Word文档中出现了54次。

对于关键字X的每个实例，我想添加一条注释，指出“请用vuvuzela替换[关键字X]”。 （其中关键字X是所传递的实际值）

对于关键字Y的每个实例，我想添加一条注释“请在[关键字Y]之后添加版权符号”。 （其中关键字Y是所传递的实际值）

对于关键字Z的每个实例，我想添加一条注释，说明“请在[关键字Z]之后添加TM符号。”（其中关键字Z是所传递的实际值）

我发现了一些有用的代码here，该代码使用户可以“硬编码”每个关键字并显示注释。

但是，这很麻烦，因为我必须为每个关键字复制并粘贴整个块，而且我有数百个。有没有一种方法可以让一个代码块循环搜索关键词，并在评论气泡中添加一长串“罐头”响应，以供添加？

最后，我不能在注释中显示关键字而不将其放在注释字段中。

非常感谢这个社区可以提供的帮助。预先感谢！

Sub CommentBubble()
Application.ScreenUpdating = False
Dim i As Long,StrCmnt As String
With ActiveDocument.range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Keyword X"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = Yes
    .Execute
  End With
  do while .Find.Found
    .Comments.Add range:=.Duplicate,Text:="Please replace [keyword X] with vuvuzela."
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True

Application.ScreenUpdating = False
With ActiveDocument.range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Keyword Y"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  do while .Find.Found
    .Comments.Add range:=.Duplicate,Text:="Please add a copyright symbol after [keyword Y]."
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True

Application.ScreenUpdating = False
With ActiveDocument.range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Keyword Z"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  do while .Find.Found
    .Comments.Add range:=.Duplicate,Text:="Please add the TM symbol after [Keyword Z]."
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True

End Sub

解决方法

根据使用两列CSV文件的想法，第一列=关键字，第二列=响应，如果有帮助，我编写了一个示例实现。在“响应”列中，可以包含占位符[关键字]，该占位符将由匹配的文本替换。列标题是可选的。

以下是CSV文件的示例：

关键字，响应
号角，请将[关键字]替换为vuvuzela。
版权，请在[关键字]之后添加版权符号。

如果您想在响应中使用逗号，则可以使用chr（44），例如

关键字，响应
号角，请将[关键字]替换为vuvuzela。
版权，如果还没有（44），请在[关键字]之后添加一个版权符号。

这是示例代码实现。
更新1 ：现在允许使用字母数字关键字。如果关键字包含任何数字，则该关键字的MatchAllWordForms设置为False，否则设置为True。另外，如果要匹配单词的所有形式，请确保将关键字写成小写。
更新2 ：已更新，仅当关键字完全由字母组成时，MatchAllWordForms = True。这意味着关键字可以包含其他字符，并且不会抛出错误，因为在这种情况下MatchAllWordForms会被简单地设置为False。

Sub CommentBubble()
    Dim Rng As Range
    Dim Line() As String
    Dim FileName As String
    Dim Keyword As String
    Dim Response As String

    With Application.FileDialog(3)
        .AllowMultiSelect = False
        .ButtonName = ""
        .InitialFileName = ""
        .Title = "Pick CSV File"
        .Filters.Clear
        .Filters.Add "CSV File","*.csv;*.txt"
        If .Show = True Then
            FileName = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False

    With CreateObject("Scripting.FileSystemObject").OpenTextFile(FileName)
        Do While Not .AtEndOfStream
            Line = Split(.ReadLine,",")
            If UBound(Line) - LBound(Line) = 1 Then
                Keyword = Trim(Line(LBound(Line)))
                Response = Trim(Line(UBound(Line)))
                If LCase(Keyword) <> "keywords" And LCase(Response) <> "response" Then
                    GoSub Find_And_Comment
                End If
            End If
        Loop
        .Close
    End With
    
    Application.ScreenUpdating = True
Exit Sub

Find_And_Comment:
    Set Rng = ActiveDocument.Content
    With Rng.Find
        .MatchAllWordForms = IIf(Keyword Like Replace(String(Len(Keyword),"*"),"*","[a-z]"),True,False)
        Do While .Execute(FindText:=Keyword)
            Response = Replace(Response,"[Keyword]",Rng.text,vbTextCompare)
            Response = Replace(Response,"chr(44)",")
            Rng.Comments.Add Range:=Rng,text:=Response
            Rng.Collapse wdCollapseEnd
        Loop
    End With
    Return
End Sub