VBA comments from excel to selected text in word

[user2021]

Hello, 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 = ActiveDocument.Content  
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

[gmayor]

The following should work only with the selected text

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, sFind 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
        sFind = LCase(ExWb.Sheets("Words").Cells(i, 1))
        Do While oRng.Find.Execute(findText:=sFind) = True
            sComment = ExWb.Sheets("Words").Cells(i, 2)
            If oRng.End > Selection.Range.End Then GoTo Skip
            oRng.Comments.Add oRng, sComment
        Loop
Skip:
        DoEvents
    Next
lbl_Exit:
    ExWb.Close
    objExcel.Quit
    Set ExWb = Nothing
    Set objExcel = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[user2021]

Many thanks!!! It works correctly:-)