Sub Take_Data_From_Word()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets(1)

Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim A As Long 'Счётчик

.Cells(1, 1).Value = "ФИО"
.Cells(1, 2).Value = "ИД"
.Cells(1, 3).Value = "Сумма"

On Error Resume Next

Set objWrdApp = GetObject(, "Word.Application")

If objWrdApp Is Nothing Then
     Set objWrdApp = CreateObject("Word.Application")
     Set objWrdDoc = objWrdApp.Documents.Open("C:\Data_1.docm")
     objWrdApp.Visible = False
End If

Set objWrdDoc = objWrdApp.Documents.Open("C:\Data_1.docm")

A = 1

Dim TableX As Object

For Each TableX In objWrdDoc.tables
     .Cells(A + 1, 1).Value = Left(objWrdDoc.tables(A).Rows(2).Cells(1).Range.Text, Len(objWrdDoc.tables(A).Rows(2).Cells(1).Range.Text) - 1)
     .Cells(A + 1, 2).Value = Left(objWrdDoc.tables(A).Rows(3).Cells(3).Range.Text, Len(objWrdDoc.tables(A).Rows(3).Cells(3).Range.Text) - 1)
     .Cells(A + 1, 3).Value = Left(objWrdDoc.tables(A).Rows(4).Cells(5).Range.Text, Len(objWrdDoc.tables(A).Rows(4).Cells(5).Range.Text) - 1)
     A = A + 1
Next TableX

.Columns("A:C").EntireColumn.AutoFit

objWrdDoc.Close False
objWrdApp.Quit

Set objWrdDoc = Nothing
Set objWrdApp = Nothing

End With
Application.ScreenUpdating = True
End Sub