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

Question

I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.

I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:

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

I need to loop through all the documents in the folder.

I have implemented the same with Excel workbooks, but I don't know how for Word documents.

Here is the code for Excel workbooks:

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

There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.

Sub OpenAndReadWordDoc()

Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select

    ' assumes that the previous procedure has been executed
    Dim oWordApp As Word.Application
    Dim oWordDoc As Word.Document
    Dim blnStart As Boolean
    Dim r As Long
    Dim sFolder As String
    Dim strFilePattern As String
    Dim strFileName As String
    Dim sFileName As String
    Dim ws As Worksheet
    Dim c As Long
    Dim n As Long

    '~~> Establish an Word application object
    On Error Resume Next
    Set oWordApp = GetObject(, "Word.Application")
    If Err Then
        Set oWordApp = CreateObject("Word.Application")
        ' We started Word for this macro
        blnStart = True
    End If
    On Error GoTo ErrHandler

    Set ws = ActiveSheet
    r = 1 ' startrow for the copied text from the Word document
    ' Last column
    n = ws.Range("A1").End(xlToRight).Column

    sFolder = "C:\Users\Excel\Desktop\Coding\Microsoft Excel\PWC\Resumes\"

    '~~> This is the extension you want to go in for
    strFilePattern = "*.doc*"
    '~~> Loop through the folder to get the word files
    strFileName = Dir(sFolder & strFilePattern)
    Do Until strFileName = ""
        sFileName = sFolder & strFileName

        '~~> Open the word doc
        Set oWordDoc = oWordApp.Documents.Open(sFileName)
        ' Increase row number
        r = r + 1
        ' Enter file name in column A
        ws.Cells(r, 1).Value = sFileName

        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
        SubAddress:="A" & r, TextToDisplay:=sFileName

        ' Loop through the columns
        For c = 2 To n
            If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
                    MatchWholeWord:=True, MatchCase:=False) Then
                ' If text found, enter Yes in column number c
                ws.Cells(r, c).Value = "Yes"
            End If
        Next c
        oWordDoc.Close SaveChanges:=False

        '~~> Find next file
        strFileName = Dir
    Loop

ExitHandler:
    On Error Resume Next
    ' close the Word application
    Set oWordDoc = Nothing
    If blnStart Then
        ' We started Word, so we close it
        oWordApp.Quit
    End If
    Set oWordApp = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Function GetDirectory(path)
   GetDirectory = Left(path, InStrRev(path, "\"))
End Function

In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same xy coordinate.

Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!