Sub GetWordPageData()
 'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim StrDocNm As String, lRow As Long, i As Long
Dim WkSht As Worksheet, StrTxt As String
'Check whether the document exists
StrDocNm = "C:\Users\" & Environ("Username") & "\Documents\Document Name.doc"
If Dir(StrDocNm) = "" Then
  MsgBox "Cannot find the designated document: " & StrDocNm, vbExclamation
  Exit Sub
End If
Set WkSht = ActiveSheet
lRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(Filename:=StrDocNm, AddToRecentFiles:=False, Visible:=False)
For i = 1 To lRow
  StrTxt = ""
  With wdDoc.Content
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = WkSht.Cells(i, 1).Text
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      StrTxt = StrTxt & " " & .Duplicate.Information(wdActiveEndPageNumber)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  WkSht.Cells(i, 2).Value = Replace(Trim(StrTxt), " ", ", ")
Next
wdDoc.Close SaveChanges:=False
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub