Untested but try
Sub Test()Dim xlApp As Object, xlBook As Object, xlSheet As Object
Dim oRng As Range
Dim lngIndex As Long, lngRow As Long
Dim oDoc As Document
Dim arrWords() As String
arrWords = Split("Test1,Test2,Test3", ",")
Set xlApp = GetObject(, "Excel.Application")
Set xlSheet = xlApp.Sheets("Sheet1")
Set oRng = ActiveDocument.Range
For lngIndex = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=arrWords(lngIndex))
lngRow = xlSheet.Cells(xlSheet.Rows.Count, 1 + lngIndex).End(-4162).Row + 1
xlSheet.Cells(lngRow, 1).Offset(, lngIndex) = oRng.Text
oRng.Collapse 0
Loop
End With
Next
End Sub