Macro to export keyword sentences from Word to Excel

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

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:

Code:

---

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

---

Gracias!

.

Quote:

---

Originally Posted by 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:

Code:

---

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.