Search word doc for text and paste into excel file

Question

I'm pretty sure I'm real close on this one, I used a combination of this question for text selection and this other question regarding importing tables for what I've gotten so far.

I'm trying to find certain value in a word file, with the most identifiable preceding text being a "VALUE DATE" on the line above it. The value I want is in the line below this "VALUE DATE". I want the macro to be able to search the word doc for the desired text and paste it into excel, as normally we would have to do this manually about 50 times. Very tedious.

For reference here's what the text looks like in the word doc.

  TRANSACTIONS              VALUE DATE
                              31-08-15                            X,XXX.XX

I want to pull value X,XXX.XX and paste it into a destination in excel, let's just use A1 for simplicity.

Sub wordscraper9000()
    Dim oWordApp As Object, oWordDoc As Object
    Dim FlName As String
    '''''dim tbl as object  --> make string
    Dim TextToFind As String, TheContent As String
    Dim rng1 As Word.Range
    FlName = Application.InputBox("Enter filepath of .doc with desired information")
    'establish word app object
    On Error Resume Next
    Set oWordApp = GetObject(, "Word.application")
    If Err.Number <> 0 Then
        Set oWordApp = CreateObject("Word.application")
    End If
    Err.Clear
    On Error GoTo 0
    oWordApp.Visible = True
    'open word doc
    Set oWordDoc = oWordApp.documents.Open(FlName)
        '--> enter something that will skip if file already open
    '''''set tbl = oworddoc.tables(1) --> set word string
    'declare excel objects
    Dim wb As Workbook, ws As Worksheet
    'Adding New Workbook
    Set wb = Workbooks.Add
    'Saving the Workbook
    ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
    Set ws = wb.Sheets(1)
    'what text to look for
    TextToFind = "VALUE DATE"
    '''''problems here below
    Set rng1 = oWordApp.ActiveDocument.Content
    rng.Find.Execute findtext:=TextToFind, Forward:=True
    If rng1.Find.found Then
        If rng1.Information(wdwithintable) Then
            TheContent = rng.Cells(1).Next.Range.Text 'moves right on row
        End If
    Else
        MsgBox "Text '" & TextToFind & "' was not found!"
    End If
    'copy text range and paste into cell A1
    'tbl.range.copy
    ws.Range("A1").Activate
    ws.Paste
End Sub

At the line

set rng1.oWordApp.ActiveDocument.Content

I get a run-time 8002801d error - automation error, library not registered.

I couldn't find anything on here that was perfect for my case, however the 2nd question I linked to is very, very close to what I want, however I'm trying to import text rather than a table.

Answer 1

This will extract the "X,XXX.XX" value into a new Excel file, sheet 1, cell A1:

Option Explicit

Public Sub wordscraper9000()
    Const FIND_TXT  As String = "VALUE DATE"
    Const OUTPUT    As String = "\DummyWB.xlsx"

    Dim fName As Variant, wrdApp As Object, wrdTxt As Variant, sz As Long, wb As Workbook

    fName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
            "Enter filepath of .doc with desired information")

    If fName <> False Then

        'get Word text --------------------------------------------------------------------
        On Error Resume Next
        Set wrdApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            Set wrdApp = CreateObject("Word.Application")
            Err.Clear
        End If: wrdApp.Visible = False
        wrdTxt = wrdApp.Documents.Open(fName).Content.Text: wrdApp.Quit

        'get value ------------------------------------------------------------------------
        sz = InStr(1, wrdTxt, FIND_TXT, 1)
        If Len(sz) > 0 Then
            wrdTxt = Trim(Right(wrdTxt, Len(wrdTxt) - sz - Len(FIND_TXT)))
            wrdTxt = Split(Trim(Right(wrdTxt, InStr(wrdTxt, " "))))(0)

            'save to Excel ----------------------------------------------------------------
            Set wb = Workbooks.Add
            wb.Sheets(1).Cells(1, 1) = wrdTxt
            Application.DisplayAlerts = False
            wb.Close True, CreateObject("WScript.Shell").SpecialFolders("Desktop") & OUTPUT
            Application.DisplayAlerts = True
        End If
    End If
End Sub

.

This code is specific to this pattern:

"Reference" (any # of spaces) (any word without a space) (any # of spaces) "ExtractValue"

• Search for reference (FIND_TXT)
• Find and skip the next word (text without a space in it) after any number of spaces or empty lines
• Extract the second word, separated by any number of spaces or lines from the skipped first word

Answer 2

Modifying your code a bit and if the information you want is in a fixed position within a Word table, you can do this:

Sub wordscraper90000()
    Dim oWordApp As Object, oWordDoc As Object
    Dim FlName As String
    Dim TheContent As String
    FlName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
        "Enter filepath of .doc with desired information")

    'establish word app object
    On Error Resume Next
    Set oWordApp = GetObject(, "Word.application")
    If Err.Number <> 0 Then
        Set oWordApp = CreateObject("Word.application")
    End If
    Err.Clear
    On Error GoTo 0
    oWordApp.Visible = True
    'open word doc
    Set oWordDoc = oWordApp.Documents.Open(FlName)
    'declare excel objects
    Dim wb As Workbook, ws As Worksheet
    'Adding New Workbook
    Set wb = Workbooks.Add
    'Saving the Workbook
    ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
    Set ws = wb.Sheets(1)
    TheContent = oWordDoc.Tables.Item(1).Cell(2, 3).Range.Text
    ws.Range("A1").Activate
    ws.Range("A1").Value = Trim(Replace(TheContent, Chr(7), Chr(32))) 'Remove strange character at the end
End Sub

Whereas the data to be extracted it is in row 2, column 3: