VBA in MS word: adding comments from excel to selected text-CodePudding

I have macro in word adding comments gathered in excel (for the example please see the citation from doc and excel below) to the matching words from word document. I would like to add those comments only to the selected part of the text and not to the whole document (in the example below selected will be first 4 lines of text so the macro should add comment "please call 1111111" to the "issue1" and comment "please call 2222222" to the "issue2" but leave second occurrence of "issue1" in 6 line without comment as this was not in the selection. Any ideas how to solve this?

Document in word, example:

1word issue1 word word word word
2word word word word word word
3word word word word issue2 word
4word word word word word word
5word word word word word word
6word word issue1 word word word
7word word word issue3 word word

Table in excel with text to be added as comments (2 columns):

"issue1" "please call 1111111"
"issue2" "please call 2222222"
"issue3" "please call 3333333"

My macro now looks for words from selected part (first 4 lines of document) but adding comments to the whole text till the end of the document meaning also adding comment to "issue1" that occurs in line no 6 and which was not selected.

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:\Document\excelWITHcomments.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

CodePudding user response：

lastPosition saves the end of your selection. After each Find.Execute there is a check if the start of the found range is before the saved lastPosition. If it has gone behind lastPosition the find-loop stops.

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:\Document\excelWITHcomments.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