Hello Friends, I have this code for extracting word tables to excel sheet, but it loses word format.
Can we adjust this code so that, not losing word format??
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
Dim allTables As Collection '<<
On Error Resume Next
ActiveSheet.Range("A: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
Set allTables = GetTables(wdDoc) '<<< see function below
tableNo = allTables.Count
tableTot = allTables.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 allTables(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 Sub
'extract all tables from Word doc into a collection
Function GetTables(doc As Object) As Collection
Dim shp As Object, i, tbls As Object
Dim tbl As Object
Dim rv As New Collection
'find tables directly in document
For Each tbl In doc.Tables
rv.Add tbl
Next tbl
'find tables hosted in shapes
For i = 1 To doc.Shapes.Count
On Error Resume Next
Set tbls = doc.Shapes(i).TextFrame.TextRange.Tables
On Error GoTo 0
If Not tbls Is Nothing Then
For Each tbl In tbls
rv.Add tbl
Next tbl
End If
Next i
Set GetTables = rv
End Function
Last edited by HansV on 02 Oct 2021, 15:24, edited 1 time in total.
Reason:to add [code]...[/code] tags
Sub ImportWordTables()
Dim wdApp As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long
Dim tableStart As Long
Dim tableTot As Long
Dim resultRow As Long
Dim fStart As Boolean
ActiveSheet.Range("A: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)
On Error Resume Next
Set wdApp = GetObject(Class:="Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject(Class:="Word.Application")
fStart = True
End If
On Error GoTo ErrHandler
Set wdDoc = wdApp.Documents.Open(Filename:=wdFileName) 'open Word file
tableTot = wdDoc.Tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
ElseIf tableTot > 1 Then
tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
resultRow = 4
For tableNo = tableStart To tableTot
wdDoc.Tables(tableNo).Range.Copy
Cells(resultRow, 1).Select
ActiveSheet.PasteSpecial Format:="HTML"
resultRow = resultRow + wdDoc.Tables(tableNo).Rows.Count + 1
Next tableNo
ExitHandler:
On Error Resume Next
wdDoc.Close SaveChanges:=False
If fStart Then
wdApp.Quit SaveChanges:=False
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation, "Import Word Table"
Resume ExitHandler
End Sub
The macro now also allows for .docx and .docm files.
Sub ImportWordTables()
Dim wdApp As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long
Dim tableStart As Long
Dim tableTot As Long
Dim resultRow As Long
Dim fStart As Boolean
Dim wSheet As Worksheet
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)
On Error Resume Next
Set wdApp = GetObject(Class:="Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject(Class:="Word.Application")
fStart = True
End If
On Error GoTo ErrHandler
Set wdDoc = wdApp.Documents.Open(Filename:=wdFileName) 'open Word file
tableTot = wdDoc.Tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
ElseIf tableTot > 1 Then
tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
resultRow = 4
For tableNo = tableStart To tableTot
Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wdDoc.Tables(tableNo).Range.Copy
wSheet.Cells(resultRow, 1).Select
wSheet.PasteSpecial Format:="HTML"
Next tableNo
ExitHandler:
On Error Resume Next
wdDoc.Close SaveChanges:=False
If fStart Then
wdApp.Quit SaveChanges:=False
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation, "Import Word Table"
Resume ExitHandler
End Sub