Macro to export keyword sentences from Word to Excel

[prefect]

Hi there,

I am using Word and Excel 2013 and have the following problem.

I have a large Word file consisting of news articles about exchange-listed companies. I need to extract key data (date of article and company tickers) to Excel. I have a macro that exports sentences from MS Word that contain a certain keyword to a separate Excel file, but I need to export sentences that contain not one possible keyword, but one of several possible keywords, e.g. "January" and/or "NYSE" and/or "NASDAQ" etc.

Here's the code for exporting sentences with one keyword (in this case "shall"), courtesy of lucas from this forum. How do I update this code to export sentences that contain not one, but one of several possible keywords? I.e. I need the macro to search for more than one possible keyword for exporting the sentence to Excel.

Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.Text = "shall" ' the word to look for
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xls").Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub



I have tried making changes to this code so far nothing has worked. Any help would be appreciated.

Best regards,
Prefect

[gmayor]

If you wish to use the Range.Find method, then you will need a list of the words to check for and loop through the list. It may be that there are sentences that contain more than one of the words, in which case they will be duplicated in the worksheet. There is no need to copy and paste which is slow. You can write the range directly to the worksheet. The following, based on your original, should work. Add your own word list each in quotes and separated by a comma as shown:

Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim vWords As Variant
Dim i As Long

vWords = Array("shall", "lorem", "ipsum") 'The list of words or phrases
If objSheet Is Nothing Then

On Error Resume Next
Set appExcel = GetObject(, "Excel.Application")
If Err Then
Set appExcel = CreateObject("Excel.Application")
End If
On Error GoTo 0
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xlsx").Sheets("Sheet1")
End If
For i = 0 To UBound(vWords)
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.Text = vWords(i)
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
intRowCount = objSheet.Range("A" & objSheet.Rows.Count).End(-4162).Row + 1
objSheet.Cells(intRowCount, 1) = aRange.Text
aRange.Collapse wdCollapseEnd
End If
Loop While .Found
End With
Next i
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

[prefect]

Gracias!

[nitesh12]

.

[nitesh12]

If you wish to use the Range.Find method, then you will need a list of the words to check for and loop through the list. It may be that there are sentences that contain more than one of the words, in which case they will be duplicated in the worksheet. There is no need to copy and paste which is slow. You can write the range directly to the worksheet. The following, based on your original, should work. Add your own word list each in quotes and separated by a comma as shown:

Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim vWords As Variant
Dim i As Long

vWords = Array("shall", "lorem", "ipsum") 'The list of words or phrases
If objSheet Is Nothing Then

On Error Resume Next
Set appExcel = GetObject(, "Excel.Application")
If Err Then
Set appExcel = CreateObject("Excel.Application")
End If
On Error GoTo 0
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xlsx").Sheets("Sheet1")
End If
For i = 0 To UBound(vWords)
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.Text = vWords(i)
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
intRowCount = objSheet.Range("A" & objSheet.Rows.Count).End(-4162).Row + 1
objSheet.Cells(intRowCount, 1) = aRange.Text
aRange.Collapse wdCollapseEnd
End If
Loop While .Found
End With
Next i
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub



Is there a way to modify the code so that instead of copying whole sentence, it picks only the next word??
for example:
"Scheme : LA172 Last Rephased on : 29-10-2001"

If i search for Scheme, it should give output as only LA172 not the whole sentence. I want it to run it for 6 different values and place the output in 6 different cell of same excel sheet.