如何打開文件中的每個 word 文檔並提取數據以放入 Excel VBA 中的單元格

Question

在工作中，我必須單獨進入 400 多個文件，並獲取 word 文檔的主題和編寫日期（在報告中找到）並將其放入 Excel 列表中。 我找到了搜索word文檔並獲取正在工作的數據的代碼，但我一直在玩它，但我無法讓它循環瀏覽文件夾中的所有文件。 現在我一次只能做一個文件，這並不比手工做快。

代碼獲取主題並將其放入單元格中。

理想情況下，代碼將在一個單元格中顯示它從中獲取數據的文件，並在其旁邊的單元格中顯示主題。

我觀看的視頻說循環播放我需要使用 dir 函數，但我無法按照我的方式工作。

這是我擁有的代碼，一次獲取一個文件。

Sub ExtractText()
Dim cDoc As Word.Document
Dim cRng As Word.Range
Dim i As Long
i = 2

Dim wordapp As Object
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open "c:\code practice\file1"
wordapp.Visible = True

Set cDoc = ActiveDocument
Set cRng = cDoc.Content

With cRng.Find
    .Forward = True
    .Text = "SUBJECT:"
    .Wrap = wdFindStop
    .Execute
    Do While .Found
        'Collapses a range or selection to the starting or ending position
        cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        cRng.MoveEndUntil Cset:="INSPEC"
        Cells(i, 1) = cRng
        cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        .Execute
        i = i + 1
    Loop
End With
wordapp.Quit
Set wordapp = Nothing

End Sub

Answer 1

此FileSystemObject將幫助您進行迭代。 我不想過多地使用您現有的代碼，因此這可能不是最快或最直接的路線。 我會鼓勵你在未來玩這個。

Option Explicit
Sub IterateMSWordExtracts()
    
    Dim I As Integer
    Dim FSO As Object
    Dim DocumentFolder As Object
    Dim oFile As Object
    
    Set FSO = CreateObject("Scripting.filesystemobject")
    Set DocumentFolder = FSO.GetFolder("FOLDER CONTAINING ALL FILES")
    
    For Each oFile In DocumentFolder.Files
        Debug.Print oFile.Path
        If Right(oFile.Path, 4) = "docx" Then
            ExtractText oFile.Path
        End If
    Next oFile

End Sub
Sub ExtractText(DocumentDirectory As String)
Dim cDoc As Word.Document
Dim cRng As Word.Range
Dim I As Long
I = 2

Dim wordapp As Object
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open DocumentDirectory
wordapp.Visible = True

Set cDoc = ActiveDocument
Set cRng = cDoc.Content

With cRng.Find
    .Forward = True
    .Text = "SUBJECT:"
    .Wrap = wdFindStop
    .Execute
    Do While .Found
        'Collapses a range or selection to the starting or ending position
        cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        cRng.MoveEndUntil Cset:="INSPEC"
        Cells(I, 1) = cRng
        cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        .Execute
        I = I + 1
    Loop
End With
wordapp.Quit
Set wordapp = Nothing

End Sub