Word VBA可将数据从多个Word文档复制到一个Excel工作簿

Question

我有大约100个Word文档，每个文档我都想要复制数据并将其粘贴到一个excel工作簿中。

我想到了以下代码，该代码打开一个Word文档，将数据复制，粘贴到Excel中并关闭Word文档：

Sub WordDataToExcel()
Dim myObj
 Dim myWB
 Dim mySh
 Dim txt As String, Lgth As Long, Strt As Long
 Dim i As Long
 Dim oRng As Range
 Dim Tgt As String
 Dim TgtFile As String
 Dim arr()
 Dim ArrSize As Long
 Dim ArrIncrement As Long
 ArrIncrement = 1000
 ArrSize = ArrIncrement
 ReDim arr(ArrSize)
Dim wrdDoc As Object

Documents.Open ("D:\ekr5_i.doc")

TgtFile = "result.xlsx"

Tgt = "D:\" & TgtFile

'finds the text string of Lgth lenght
 txt = "thetext"
 Lgth = 85
 Strt = Len(txt)

 'Return data to array
 With Selection
 .HomeKey unit:=wdStory
 With .Find
 .ClearFormatting
 .Forward = True
 .Text = txt
 .Execute
 While .Found
 i = i + 1
 Set oRng = ActiveDocument.Range _
 (Start:=Selection.Range.Start + Strt, _
 End:=Selection.Range.End + Lgth)
 arr(i) = oRng.Text
 oRng.Start = oRng.End
 .Execute
 If i = ArrSize - 20 Then
 ArrSize = ArrSize + ArrIncrement
 ReDim Preserve arr(ArrSize)
 End If
 Wend
 End With
 End With
 ReDim Preserve arr(i)

 'Set target and write data
 Set myObj = CreateObject("Excel.Application")
 Set myWB = myObj.Workbooks.Open(Tgt)
 Set mySh = myWB.Sheets(1)
 With mySh
 .Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
 End With

 'Tidy up
 myWB.Close True
 myObj.Quit
 ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
 Set mySh = Nothing
 Set myWB = Nothing
 Set myObj = Nothing
 End Sub

我需要找到一种方法来遍历文件夹中的所有文档并将数据复制到Excel。 我已经在Excel工作簿中实现了相同的功能，但是我不知道如何将其用于Word文档。

这是Excel工作簿的代码：

Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)

With oFldialog
If .Show = -1 Then
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    sFolderName = .SelectedItems(1)
End If
End With

Set oFolder = FSO.GetFolder(sFolderName)

Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook

For Each oFile In oFolder.Files
Workbooks(Pivot).Activate

x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1

Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
    Workbooks(sSourceName).Sheets(1).[A80:Q94].copy

Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next

Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Answer 1

在Excel和Word之间可以做很多事情。我不确定我是否完全理解您的问题。以下脚本可能会对您有所帮助；随着时间的推移，它肯定对我很有帮助。如果您需要其他不同的内容，请进一步描述您的问题，以更好地阐明您面临的问题。

n = n+1

在这种情况下，无论您搜索B1：K1标题（或右侧的标题）中的内容如何，​​都将打开，扫描文件夹中的每个word文档，并找到B1：K1中的字符串，一个“ x”放置在相同的xy坐标中。

再次，如果这样做无济于事，请更好地描述您的问题，我将回传其他解决方案。谢谢！