Sub SentencesToExcel() Dim appXL As Excel.Application Dim wbkXLSource As Excel.Workbook Dim wbkXLNew As Excel.Workbook Dim strSearch() As String Dim var Dim r As Word.Range Dim j As Long Set appXL = CreateObject("Excel.Application") Set wbkXLSource = appXL.Workbooks.Open(FileName:="c:\ZZZ\Test\test2\WordList.xls") Set wbkXLNew = appXL.Workbooks.Add For var = 0 To 2 ' build the array of search words from the source Excel file ReDim Preserve strSearch(var) strSearch(var) = wbkXLSource.Worksheets("Sheet1").Cells(var + 1, 1).Value Next ' close the source Excel file as do not need it wbkXLSource.Close ' destroy its object Set wbkXLSource = Nothing j = 1 ' for each search words For var = 0 To UBound(strSearch()) ' make a range ovbject of the whole document Set r = ActiveDocument.Range With r.Find ' with each Found Do While .Execute(Findtext:=strSearch(var), Forward:=True) _ = True ' expand to the sentence r.Expand Unit:=wdSentence ' and put in the next cell in the new Excel file wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = r.Text j = j + 1 r.Collapse 0 Loop End With Next appXL.Visible = True 'wbkXLNew.SaveAs FileName:="valid_path" 'Set wbkXLNew = Nothing 'appXL.Quit 'Set appXL = Nothing End Sub
var
This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)