vba - How to copy tables from multiple Word files to separate worksheets in Excel, naming the worksheet the name of the Word doc?

Question

I have used the VBA macro below to put multiple tables from multiple Word documents into one worksheet in Excel.

I want the multiple tables from each different Word doc to go into different worksheets with the worksheets named the name of the Word doc.

Sub ImportWordTable()

    Dim WordApp As Object
    Dim WordDoc As Object
    Dim arrFileList As Variant, FileName As Variant
    Dim tableNo As Integer                            'table number in Word

    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim Target As Range

    'On Error Resume Next

    arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
                                              "Browse for file containing table to be imported", , True)

    If Not IsArray(arrFileList) Then Exit Sub         '(user cancelled import file browser)

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True

    Range("A:AZ").ClearContents
    Set Target = Range("A1")

    For Each FileName In arrFileList
        Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)

        With WordDoc
            tableNo = WordDoc.tables.Count
            tableTot = WordDoc.tables.Count
            If tableNo = 0 Then
                MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"

            ElseIf tableNo > 1 Then
                tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
                                   "Enter the table to start from", "Import Word Table", "1")
            End If

            For tableStart = 1 To tableTot
                With .tables(tableStart)
                    .Range.Copy
                    'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
                    Target.Activate
                    ActiveSheet.Paste

                    Set Target = Target.Offset(.Rows.Count + 2, 0)
                End With
            Next tableStart

            .Close False
        End With

    Next FileName

    WordApp.Quit

    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

Answer 1

Something like the following, perhaps. Since I can't replicate your documents my test environment wasn't identical...

The following code declares a Word.Table and a Excel.Worksheet object to the list of declared variables.

The Worksheet object is set to ActiveSheet and later to each added worksheet. Using an object instead of a selection or "active" something is almost always preferable - then it's clearer for both human and VBA what's is meant. ws is also used to more exactly define the Range specifications.

Before looping the tables, the worksheet Name is set to the value stored in Filename for the Word document.

The Table object is set to the WordDoc.tables(tableStart) table. It's more efficient to work with an object instead of querying the full "path" to an object each time. It's also easier to read.

Before looping to the next Word document a new worksheet is added.

Sub ImportWordTable()

    Dim WordApp As Object
    Dim WordDoc As Object
    Dim tbl As Object
    Dim arrFileList As Variant, FileName As Variant
    Dim tableNo As Integer                            'table number in Word

    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim ws As Worksheet
    Dim Target As Range

    'On Error Resume Next

    arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
                                              "Browse for file containing table to be imported", , True)

    If Not IsArray(arrFileList) Then Exit Sub         '(user cancelled import file browser)

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True

    Set ws = ActiveSheet
    ws.Range("A:AZ").ClearContents

    For Each FileName In arrFileList
        Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
        With WordDoc
            tableNo = WordDoc.tables.Count
            tableTot = WordDoc.tables.Count
            If tableNo = 0 Then
                MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"

            ElseIf tableNo > 1 Then
                tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
                                   "Enter the table to start from", "Import Word Table", "1")
            End If

            ws.Name = FileName
            For tableStart = 1 To tableTot
                Set Target = ws.Range("A1")
                Set tbl = .tables(tableStart)
                With tbl
                    .Range.Copy
                    'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
                    Target.Activate
                    ws.Paste

                    Set Target = Target.Offset(.Rows.Count + 2, 0)
                End With
            Next tableStart

            .Close False
        End With
        Set ws = ws.Parent.Worksheets.Add

    Next FileName
    ws.Delete 'the last sheet is one too many
    WordApp.Quit

    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub