Import multiple Word Documents into Excel using VBA

[daveasu]

I have 100+ Word documents that I need to import into Excel

The code below from this recent thread works perfectly with the format of the Word docs we are using.

Import multiple Word tables into Excel using VBA - Retaining some original Word formatting

Hi I am trying to extract and import a number of tables from a word document (this number can vary between documents) There are normally only 2 columns of information (but on occasion can be more) I have the following code which will extract and import all the tables into my excel document...

www.mrexcel.com

Would it be possible to modify the code to choose the folder containing the Word docs, and then import the content of each document on a new worksheet? (and name the worksheet the same name as the Word doc?)

Sub ImportWordTable()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer

On Error Resume Next

ActiveSheet.Range("A4:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    tableNo = wdDoc.tables.Count
    tableTot = wdDoc.tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableStart = 1 To tableTot
        With .tables(tableStart)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With

End Sub

 

[lrobbo314]

Here is an example of how you can use the 'Main' sub below to call your sub in the OP and use the file name as a variable for your code.

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "C:\USERS\USERNAME\DESKTOP\YOURFOLDER\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim fil As Object

For Each fil In fold.Files
    yourSub fil.path
Next fil

End Sub

Sub yourSub(path)
Debug.Print path
End Sub

 

[daveasu]

Thank you lrobbo, I'm afraid that I'm not familiar enough with VBA to completely integrate the two sections of code.

Will your code also import the content of each document on a new worksheet and name the worksheet the same name as the Word doc?

 

[lrobbo314]

This is untested but should at least get you going in the right direction.

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "C:\USERS\USERNAME\DESKTOP\YOURFOLDER\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim LR As Long: LR = 4
Dim fil As Object

ActiveSheet.Range("A4:AZ10000").ClearContents

For Each fil In fold.Files
    ImportWordTable fil.path, LR
Next fil

End Sub

Sub ImportWordTable(docPath As String, ByRef resultRow As Long)

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim tableStart As Integer
Dim tableTot As Integer

On Error Resume Next

Set wdDoc = GetObject(docPath) 'open Word file

With wdDoc
    tableNo = wdDoc.tables.Count
    tableTot = wdDoc.tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    For tableStart = 1 To tableTot
        With .tables(tableStart)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With

End Sub