MS word中的VBA:将excel中的注释添加到选定的文本中

Question

我在word中添加了在excel中收集的注释(示例请参阅下面doc和excel的引用)到word文档中的匹配单词。我想将这些注释仅添加到文本的选定部分。而不是整个文档(在下面的例子中选中的将是前四行文本)，所以宏应该添加注释"请致电1111111"对于"问题"如有意见请致电2222222对"问题"的看法但是留下第二次出现的&;issue1&;在6行没有评论，因为这不是在选择。有办法解决这个问题吗?

word格式的文档，示例:

1word issue1 word word word word word word word word word word word word word word word word word word word word word word word word word
4word word word word word word word word
5word word word word word word word word
6word word word word word word word
7word word word issue3 word word word

表格在excel中添加文本作为注释(2列):

"issue1"请致电1111111">
issue2"请致电2222222">
issue3"请致电333333">

我的宏观现在从选定的部分(文档的前4行)中查找单词，但在整个文本中添加注释直到文档末尾，这意味着也要在"issue1"中添加注释它出现在第6行，并且没有被选中。

Sub InsertCommentFromExcel()  
Dim objExcel As Object   
Dim ExWb As Object  
Dim strWorkBook As String  
Dim i As Long  
Dim lastRow As Long  
Dim oRng As range  
Dim sComment As String  
strWorkBook = "C:DocumentexcelWITHcomments.xlsx"   
Set objExcel = CreateObject("Excel.Application") 
Set ExWb = objExcel.Workbooks.Open(strWorkBook)  
lastRow = ExWb.Sheets("Words").range("A" & ExWb.Sheets("Words").Rows.Count).End(-4162).Row  
For i = 1 To lastRow  
Set oRng = Selection.Range  
Do While oRng.Find.Execute(ExWb.Sheets("Words").Cells(i, 1)) = True  
sComment = ExWb.Sheets("Words").Cells(i, 2)  
oRng.Comments.Add oRng, sComment  
Loop 
Next  
ExWb.Close  
lbl_Exit:  
Set ExWb = Nothing  
Set objExcel = Nothing  
Set oRng = Nothing  
Exit Sub  
End Sub

Answer 1

lastPosition保存选择的结束。在每个Find.Execute之后，检查找到的范围的开始是否在保存的lastPosition之前。如果它在lastPosition后面，查找循环停止。

Sub InsertCommentFromExcel()
Dim objExcel As Object
Dim ExWb As Object
Dim strWorkBook As String
Dim i As Long
Dim lastRow As Long
Dim oRng As Range
Dim sComment As String
strWorkBook = "C:DocumentexcelWITHcomments.xlsx"
Set objExcel = CreateObject("Excel.Application")
Set ExWb = objExcel.Workbooks.Open(strWorkBook)
lastRow = ExWb.Sheets("Words").Range("A" & ExWb.Sheets("Words").Rows.Count).End(-4162).Row

Set oRng = Selection.Range
Dim firstPosition As Long, lastPosition As Long
firstPosition = oRng.Start
lastPosition = oRng.End

For i = 1 To lastRow
Do While oRng.Find.Execute(ExWb.Sheets("Words").Cells(i, 1)) = True
If oRng.Start > lastPosition Then Exit Do
sComment = ExWb.Sheets("Words").Cells(i, 2)
oRng.Comments.Add oRng, sComment
Loop
Set oRng = ActiveDocument.Range(firstPosition, lastPosition)
Next
ExWb.Close
lbl_Exit:
Set ExWb = Nothing
Set objExcel = Nothing
Set oRng = Nothing
Exit Sub
End Sub