Question

我非常确定我真的很接近这一点，我使用了this question for text selection和this other question regarding importing tables的组合来实现我迄今所获得的目标。

我试图在word文件中找到某个值，其中最可识别的前一个文本是＆＃34; VALUE DATE＆＃34;在它上面的线上。我想要的值在这个＆＃34; VALUE DATE＆＃34;下面的行中。我希望宏能够在单词doc中搜索所需的文本并将其粘贴到excel中，因为通常我们必须手动执行此操作大约50次。很乏味。

此处参考文字在文档中的内容。

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

我想拉取值X，XXX.XX并将其粘贴到excel中的目的地，为了简单起见，我们只使用A1。

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

在

行

set rng1.oWordApp.ActiveDocument.Content

我收到运行时8002801d错误 - 自动化错误，库未注册。

我在这里找不到任何适合我案例的内容，但是我所关联的第二个问题与我想要的非常非常接近，但是我试图导入文本而不是表

Answer 1

这会将“X，XXX.XX”值提取到新的Excel文件中，第1页，单元格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

此代码特定于此模式：

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

搜索参考（FIND_TXT）
在任意数量的空格或空行之后找到并跳过下一个单词（没有空格的文本）
提取第二个单词，由跳过的第一个单词

Answer 2

稍微修改你的代码，如果你想要的信息在Word表格中的固定位置，你可以这样做：

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

而要提取的数据是第2行第3列：

搜索word doc文本并粘贴到excel文件中

2 个答案: