How can I open each word document in my file and extract data to put into a cell in Excel VBA

Question

At work I have to go into over 400 files individually and grab the subject of the word document and the date it was written (this is found within the report) and put that into an excel list. I've found code to search through a word document and get this data which is working but I've been playing around with it and I can't get it to loop through all files in a folder. Right now I can only do one file at a time which isn't ay faster than doing it by hand.

The code gets the subject and puts it in a cell.

Ideally the code would display the file that it took the data from in one cell and in the cell beside it, it would display the subject.

A video I watched said to loop through I need to use a dir function but I can't get that to work the way I'm doing it.

This is the code that I have that takes one file at a time.

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

This FileSystemObject will help you iterate. I didn't want to mess too much with your existing code, so this may not be the fastest or most direct route. I would encourage you to play with this in the future.

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