如何解决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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。