Необходимо скопировать в Exсel все таблицы

    Sub ktos()
        
        'В константе "strDocFullName" нужно указать полное имя Word-документа,
            'из которого нужно скопировать таблицу.
        Const strDocFullName As String = "C:\Users\Swokooy\Desktop\ktos\tom1.doc"
        
        'Для написания макроса, удобно подключить библиотеку для работы
            'с программой "Word". Затем можно будет отключить эту библиотеку:
        'Tools - References... - Microsoft Word версия Object Library.
        'Dim myWord As Word.Application
        'Dim docSource As Word.Document
        
        
        'Запуск и VBA-наименование программы "Word".
            'Даём программе "Word" VBA-имя "myWord" и через
            'это имя будем работать с программой Word в макросе.
        Set myWord = CreateObject(Class:="Word.Application")
        
        'Делаем программу Word видимой, чтобы было удобно писать код.
        myWord.Visible = True
        
        'Открытие и VBA-наименование Word-файла.
        Set docSource = myWord.Documents.Open(Filename:=strDocFullName)
        
        'Копирование первой таблицы в Word-файле.
        'Range - это фрагмент Word-файла, где находится таблица.
        docSource.Tables(1).Range.Copy
        
        'Выделение ячейки, куда будут вставлены данные.
            'Для вставки в Excel будет использоваться метод "PasteSpecial",
            'который относится к объекту "Worksheet". Метод "PasteSpectial"
            'ещё есть у объекта "Range". У объекта "Worksheet" нельзя
            'указать ячейку, куда надо вставить, поэтому нужно заранее
            'выделить нужную ячейку, куда будут вставлены данные.
        ActiveSheet.Range("A1").Select
        
        'Вставка скопированной таблицы в активный Excel-лист в выделенную ячейку.
        'Код записал с помощью макрорекордера, делая такие действия в "Excel 2010":
            'вкладка "Главная" - группа "Буфер обмена" - "Вставить (со стрелкой)" -
            '"Специальная вставка..." - кружок "Вставить" - "HTML".
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False
        
        'Чтобы в буфере обмена не было много данных, очищаем буфер обмена,
            'копируя в него только одну ячейку.
        docSource.Tables(1).Cell(1, 1).Range.Copy
        
        'Закрытие Word-документа.
        '0 - без сохранения.
        docSource.Close SaveChanges:=0
        
        'Закрытие программы "Word".
        myWord.Quit SaveChanges:=0
        
    End Sub

Sub Swokooy()
Dim xlApp As Object, xlWs As Object, t As Table, second As Boolean
  On Error Resume Next
  Set xlApp = GetObject(, "excel.application")
  If Err Then
    Err.Clear
    Set xlApp = CreateObject("excel.application")
    If Err Then
      MsgBox "Не удалось запустить Excel", vbCritical
      Exit Sub
    End If
  End If
  On Error GoTo 0
  xlApp.Visible = True
  Set xlWs = xlApp.Workbooks.Add(-4167).Worksheets(1) '-4167=xlWBATWorksheet
  For Each t In ActiveDocument.Tables
    t.Range.Copy
    xlWs.Paste xlWs.Cells(IIf(second, xlWs.UsedRange.Rows.Count + 2, 1), 1)
    second = True
  Next
End Sub

Sub Procedure_1()
    
    'В константе "strDocFullName" нужно указать полное имя Word-документа,
        'из которого нужно скопировать таблицу.
    Const strDocFullName As String = "C:\Users\User\Desktop\Из.docx"
    
    'Для написания макроса, удобно подключить библиотеку для работы
        'с программой "Word". Затем можно будет отключить эту библиотеку:
    'Tools - References... - Microsoft Word версия Object Library.
    Dim myWord As Word.Application
    Dim docSource As Word.Document
    
    
    'Запуск и VBA-наименование программы "Word".
        'Даём программе "Word" VBA-имя "myWord" и через
        'это имя будем работать с программой Word в макросе.
    Set myWord = CreateObject(Class:="Word.Application")
    
    'Делаем программу Word видимой, чтобы было удобно писать код.
    myWord.Visible = True
    
    'Открытие и VBA-наименование Word-файла.
    Set docSource = myWord.Documents.Open(Filename:=strDocFullName)
    
    'Копирование первой таблицы в Word-файле.
    'Range - это фрагмент Word-файла, где находится таблица.
    docSource.Tables(1).Range.Copy
    
    'Выделение ячейки, куда будут вставлены данные.
        'Для вставки в Excel будет использоваться метод "PasteSpecial",
        'который относится к объекту "Worksheet". Метод "PasteSpectial"
        'ещё есть у объекта "Range". У объекта "Worksheet" нельзя
        'указать ячейку, куда надо вставить, поэтому нужно заранее
        'выделить нужную ячейку, куда будут вставлены данные.
    ActiveSheet.Range("A1").Select
    
    'Вставка скопированной таблицы в активный Excel-лист в выделенную ячейку.
    'Код записал с помощью макрорекордера, делая такие действия в "Excel 2010":
        'вкладка "Главная" - группа "Буфер обмена" - "Вставить (со стрелкой)" -
        '"Специальная вставка..." - кружок "Вставить" - "HTML".
    ActiveSheet.PasteSpecial Format:="HTML", Link:=False
    
    'Чтобы в буфере обмена не было много данных, очищаем буфер обмена,
        'копируя в него только одну ячейку.
    docSource.Tables(1).Cell(1, 1).Range.Copy
    
    'Закрытие Word-документа.
    '0 - без сохранения.
    docSource.Close SaveChanges:=0
    
    'Закрытие программы "Word".
    myWord.Quit SaveChanges:=0
    
End Sub

docSource.Tables(1).Range.Copy

Set MyRange = ActiveDocument.Content
    With MyRange
        With .Find
            .ClearFormatting
            .Text = "начало"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            If .Found Then rStart = MyRange.End: rEnd = rStart
        End With
    End With
    Set MyRange = ActiveDocument.Content
    With MyRange
        With .Find
            .Text = "окончание"
            .Execute
            If .Found Then rEnd = MyRange.Start
        End With
    End With
    If rEnd > rStart Then
        ActiveDocument.Range(rStart, rEnd).Select
        Selection.Copy
    End If

  Dim myWord As Word.Application
  Dim docSource As Word.Document

ActiveSheet.Range("A1").Select