Sub Макрос1()
    Dim flag As Boolean
    Dim WordApp As Object
    On Error Resume Next
    Set WordApp = GetObject(, "word.application")
    If WordApp Is Nothing Then Set WordApp = CreateObject("word.application"): flag = True
    On Error GoTo 0
    With WordApp
        With .Documents.Open("c:\test.doc")
            .tables(1).Range.Copy
            ActiveSheet.Paste
            .Close False
        End With
    End With
    If flag Then WordApp.Quit
    Set WordApp = Nothing
End Sub

Sub ImportWordTable()
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
    Cells(iRow, iCol) = WorksheetFunction.Trim( _
                        WorksheetFunction.Clean( _
                        Replace( _
                        Replace( _
                        Replace( _
                        .cell(iRow, iCol).Range.Text _
                        , vbLf, " ") _
                        , vbCr, " ") _
                        , vbTab, " ") _
                        ))
Next iCol
Next iRow
End With
End With

Set wdDoc = Nothing

End Sub

Sub CopyOldWordDoc()
Dim a As Variant, MainBook As Workbook, CurrentSheet As String
Set MainBook = ActiveWorkbook
CurrentSheet = ActiveSheet.Name
Dim FD As FileDialog
Dim iFileName As String
Dim Book As Workbook
Dim CheckNameBook As String
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Filters.Clear
.Filters.Add "Microsoft Word files", "*.doc"
.Filters.Add "All files", "*.*"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Title = "Открытие документа"
.ButtonName = "Открыть"
If .Show = False Then
MsgBox "Вы не указали файл - источник!", 48, "Ошибка"
Exit Sub
Else
iFileName = .SelectedItems(1)
End If
End With
Set FD = Nothing
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>­>
' Открытие документа Word и копирование содержимого в новую книгу
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>­>
Dim WordApp As Object, CopyArea As Variant
Set WordApp = CreateObject("Word.Application")
WordApp.Application.Visible = False
WordApp.Documents.Open Filename:=iFileName
With WordApp.ActiveDocument
Set CopyArea = .Range(0, .Characters.Count)
CopyArea.Select
WordApp.Selection.Copy
End With
Workbooks.Add
Dim TempBook As Workbook
Set TempBook = ActiveWorkbook
'TempBook.Worksheets(1).Cells.NumberFormat = "@"
TempBook.Worksheets(1).Range("A1").Select
ActiveSheet.Paste
'Application.CutCopyMove = False
WordApp.Quit
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>­>
' Поиск данных в новой книге и копирование их в форму
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>­>

MainBook.Activate
Worksheets(CurrentSheet).Activate
Range("A1").Activate
End Sub