[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]