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

Answer 2

Try the following macro. It allows you to choose the source folder. It creates a new worksheet for each document and outputs all tables from that document one below the other, with an empty row in between. Except for text wrapping, table formatting is preserved as much as possible.

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Dim strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
'Disable any Word Alerts
wdApp.DisplayAlerts =wdAlertsNone
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
  Set WkSht = WkBk.Sheets.Add
  WkSht.Name = Split(strFile, ".doc")(0)
  With wdDoc
    For Each wdTbl In .Tables
      With wdTbl.Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13^l]"
        .Replacement.Text = "¶"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
      End With
      r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then r = r + 2
      wdTbl.Range.Copy
      WkSht.Paste Destination:=WkSht.Range("A" & r)
    Next
    WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

Answer 3

i faced kinda similar issue where i had multiples word files(each with a table) i needed to convert them to excel , i found easy and fast way for this conversion if you have single files then just change extension of files from docx to xlsx or from doc to xls in case of multiple files run this command in cmd after giving specific path of folder containing doc/docx files

ren *.doc *.xls OR ren *.docx *.xlsx

it will rename extension of all files at once without prompting any alert , it worked for me without changing format, thanks