VB Code to Copy MS Word Tables Into Excel

[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Sub FetchWordTables()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Dim wordApp As Word.Application
  Dim wordDoc As Word.Document
  Dim oTbls As Word.Tables
  Dim oTbl As Word.Table
  Dim ws As Worksheet
  
  Dim sFileName As String
  
  Dim rTable As Range
  Dim iRows As Long
  Dim iNextFreeRow As Long
  Dim iTables As Long
  Dim iPtr As Integer
  
  Dim sMessage As String
 
  Set wordApp = CreateObject("Word.Application")
  sFileName = Application.GetOpenFilename(FileFilter:="Word documents (*.doc*), *.doc*")
  If sFileName = "False" Then Exit Sub
  
  Set wordDoc = wordApp.Documents.Open(sFileName)
  wordApp.Visible = False
  Set oTbls = wordDoc.Tables
  
  Set ws = Sheets("[COLOR=red][B]Sheet3[/B][/COLOR]")
  
  iRows = ws.UsedRange.Row + ws.UsedRange.Rows.Count + 1
  ws.Rows("1:" & CStr(iRows)).Delete Shift:=xlUp
 
  iTables = 0
  iNextFreeRow = 1
  
  For Each oTbl In oTbls
    oTbl.Select
    wordApp.Selection.Copy
    Set rTable = ws.Cells(iNextFreeRow, 1)
    rTable.Select
    ActiveSheet.Paste
    sMessage = sMessage & ", " & rTable.Address(False, False) _
             & " (" & CStr(oTbl.Rows.Count) & "x" & oTbl.Columns.Count & ")"
    iTables = iTables + 1
    iRows = oTbl.Rows.Count
    iNextFreeRow = iNextFreeRow + iRows + 1
  Next oTbl
  
  wordApp.Quit savechanges:=False
  
  sMessage = Mid(sMessage, 3)
  iPtr = InStrRev(sMessage, ",")
  If iPtr > 0 Then sMessage = Left(sMessage, iPtr - 1) & " &" & Mid(sMessage, iPtr + 1)
  
  MsgBox "Done: " & CStr(iTables) & " table" & IIf(iTables = 1, "", "s") & " imported into " _
     & sMessage & Space(10), vbOKOnly + vbInformation
  
End Sub[/SIZE][/FONT]

Sub ImportWordTable1()
'Import one table to current sheet
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
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
With wdDoc
    TableNo = 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 table number of table to import", "Import Word Table", "1")
    End If
    With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To .Rows.Count
            For iCol = 1 To .Columns.Count
                On Error Resume Next
                Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                On Error GoTo 0
            Next iCol
        Next iRow
    End With
End With
Set wdDoc = Nothing
End Sub