How to extract specific data from MS Word into Excel with VBA automatically.
We use two worksheets in Excel. The first worksheet contains the search terms that we wish to extract from Word. The second sheet, if not available is created automatically and the search term, paragraph number and the associated data extracted from Ms Word , is displayed here. watch the video before studying the accompanying code.

Watch this video on YouTube.

Here’s the complete VBA code to extract data from a Word document quickly and easily:

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")

If Err Then
    Set oWord = New Word.Application
    WordNotOpen = True
End If

On Error GoTo Err_Handler

oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Open("C:\Users\takyar\Desktop\VBA & Word.docx")       ' <= modify according to your path

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

Further Reading:

Get specific text from Word document & paste into Excel

Macro to copy line by line from word to new excel document

VBA & Word

Range.Collapse method (Word)

Sample File for Download and Practice: