searchword文本并粘贴到excel文件

我敢肯定，我真的很接近这一个，我用这个问题的文本select组合这个问题， 关于导入表到我到目前为止。

我试图find一个字的文件中的某些价值，与最可识别的前面的文字是一个“价值date”上面的行。 我想要的值在这个“VALUE DATE”下面。 我希望macros能够searchWord文档的所需文本，并将其粘贴到Excel中，通常我们将不得不手动约50次。 非常乏味。

这里的参考文字是doc中的文字。

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"

• search参考（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列：