使用 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 工作簿實現了相同的功能，但我不知道 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 之間，您可以做很多事情。 我不確定我是否完全理解你的問題。 下面的腳本可能對您有所幫助； 隨着時間的推移，它肯定對我很有幫助。 如果您需要不同的東西，請更多地描述您的問題，以更好地闡明您面臨的問題。

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

在這種情況下，無論你在 B1:K1 的標題中（或更多）的標題中搜索什么，文件夾中的每個 word 文檔都會被打開、掃描，如果找到 B1:K1 中的字符串，一個 'x ' 放置在相同的 xy 坐標中。

同樣，如果這沒有幫助，請更好地描述您的問題，我會用替代解決方案發回。 謝謝！！