Extract word tables to separate excel worsheets using VBA code

Question

I have word document with 278 tables, and need to extract 278 tables into different excel worksheets.Also I need to extract a key word from the header description file for naming the worksheets

I have a VBA code in excel to extract the word file tables into one excel sheet.

  Sub ImportWordTable()

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

  On Error Resume Next
      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 wkSht = ActiveSheet
wkSht.Range("A:AZ").ClearContents

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
        wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
      Next iCol
      resultRow = resultRow + 1
    Next iRow
  End With
  resultRow = resultRow + 1
  With wkSht
    .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
  End With
  resultRow = resultRow + 1
Next tableStart
   End With

End Sub

I would like to modify the code so that I can get each table in separate excel worksheet.

First step: Remove On Error Resume Next and run the code. Do you get errors? If yes, those need to be handled, first. Second step: Look at the VBA Help for Worksheets.Add — Cindy Meister
I don't get any error message. I need help to get the VBA code to add separate worksheets for each table. — reji mathew

Ryan Wildry Ryan Wildry · Accepted Answer · 2019-11-06T14:54:45

This doesn't solve your specific issue regarding renaming the sheets. However, I think once you have the data in Excel, you can use some VBA to iterate back through the sheets to do the rename process. Here's the Word VBA (run from Word) code to get each table from Word to Excel in a new sheet.

Option Explicit

'Run this from Word VBA
Public Sub GetTables()
    Dim Table      As Table
    Dim Doc        As Document: Set Doc = ThisDocument
    Dim xl         As Object: Set xl = CreateObject("Excel.Application")
    Dim wb         As Object: Set wb = xl.Workbooks.Add
    Dim ws         As Object

    For Each Table In Doc.Tables
        Table.Range.Copy
        Set ws = wb.Sheets.Add()
        ws.Paste
    Next

    xl.Visible = True
    wb.Save
End Sub

Extract word tables to separate excel worsheets using VBA code

1 Answers