Extract specific data from Word to Excel - excel

Question

I have a Word file that has table with 5 columns: Step, Document, Doc #, Compo and Lot #, Sign, Date. I need to search for "Lot #" and "E#" in the word file then get the Step number, the text of row contains the string into an Excel file. I found a code that need to have the keywords in Sheet 1 of Excel then extract the data from Word into Sheet 2 with 1st column as keyword, 2nd column as row number in Word and 3rd column is the text of that row.
Is there any way I can hard code the keywords with options/message box to choose the keyword into VBA module instead of Sheet 1 and get the data in Sheet 1 with 1st column as keyword, 2nd column as the value in Step column in Word and 3rd column is the text of that row?
I'm pretty new to VBA so I don't know how to implement those.
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long ' last row with data in shtSearchItem
Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem
Dim CurrRowShtExtract As Long ' current row in shtExtract
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set oDoc = GetObject(wdFileName) 'open Word file
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
What I got from the current code