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:-):clap: