Sub ImportTableToExcel()Dim xMailItem As MailItem
Dim xTable As Word.Table
Dim xDoc As Word.Document
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim I As Integer
Dim xRow As Integer
On Error Resume Next
Set xExcel = New Excel.Application
Set xWb = xExcel.Workbooks.Add
xExcel.Visible = True
Set xWs = xWb.Sheets(1)
xRow = 1
For Each xMailItem In Application.ActiveExplorer.Selection
   Set xDoc = xMailItem.GetInspector.WordEditor
   For I = 1 To xDoc.Tables.Count
       Set xTable = xDoc.Tables(I)
       xTable.Range.Copy
       xWs.Paste
       xRow = xRow + xTable.Rows.Count + 1
       xWs.Range("A" & CStr(xRow)).Select
   Next
Next
End Sub