Please help solve this problem.
Code: Select all
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