搜索word文档并粘贴到Excel文件中 [英] Search word doc for text and paste into excel file

问题描述

我很确定我真的很接近这个，我使用了这个文本选择问题和关于导入表的另一个问题，目前为止我已经得到了。

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.

我正在尝试在单词文件中找到某些值，其中最可识别的前一个文本是VALUE DATE上面的一行。我想要的值在这个VALUE DATE之下。我希望宏能够在文档中搜索所需的文本并将其粘贴到excel中，通常我们必须手动执行约50次。非常繁琐的。

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

我想拉X值，XXX.XX并将其粘贴到Excel中的目的地，我们只需使用A1来简化。

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

在行

set rng1.oWordApp.ActiveDocument.Content

I得到一个运行时的8002801d错误 - 自动化错误，库未注册。

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.

推荐答案

这将会将X，XXX.XX值提取到新的Excel文件中，表格1，单元格A1：

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

。

此代码特定于此模式：

参考（任何空格）（任何没有空格的单词）（任意空格）ExtractValue

• 搜索参考（FIND_TXT）


• 查找并跳过任意数量的空格或空行后的下一个单词（没有空格的文本）


• 提取第二个单词，用跳过的第一个单词分隔任意数量的空格或行

这篇关于搜索word文档并粘贴到Excel文件中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！