Sub extract_table_from_word()
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim oWdRange As Word.Range
Dim wdCell As Object
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
wdApp.Visible = True
Set wdDoc = wdApp.ActiveDocument
For Each wdCell In wdDoc.Tables(2).Range.Cells
With wdCell
ThisWorkbook.Sheets(1).Cells(.RowIndex, .ColumnIndex) = .Range.Text
End With
Next
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub