Sub ImportWordTables()
  Dim wdApp As Object, wdDoc As Object, sDocName As String
  Dim tableNo As Long, tableStart As Long, tableTot As Long, resultRow As Long, fStart As Boolean
  Dim wSheet As Worksheet
  
  sDocName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
              "Browse for file containing tables to be imported")
  
  If sDocName = "" 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:=sDocName) 'open Word file
  
  ' Repetition to force Word to calculate the correct count
  'tableTot = wdDoc.Tables.Count
  'tableTot = wdDoc.Tables.Count
  tableTot = wdDoc.Tables.Count
  If tableTot = 0 Then
    MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
  ElseIf tableTot > 1 Then
    tableStart = Val(InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
            "Enter the table to start from", "Import Word Table", "1"))
    If tableStart < 1 Or tableTot < tableStart Then
      Beep
      Exit Sub
    End If
  Else
    tableStart = 1
  End If
  
  resultRow = 4
  
  For tableNo = tableStart To tableTot
    Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    wSheet.Name = "Table " & tableNo
    wdDoc.Tables(tableNo).Range.Copy
    DoEvents
    wSheet.Cells(resultRow, 1).Select
    DoEvents
    wSheet.PasteSpecial Format:="HTML"
  Next tableNo
  
ExitHandler:
  On Error Resume Next
  wdDoc.Close SaveChanges:=False
  If fStart Then wdApp.Quit SaveChanges:=False
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation, "Import Word Table"
  Resume ExitHandler
End Sub