Доступ к элементам Word из Access средствами VBA

Public Sub CreateTablesFromWord()
Public Sub CreateTables()
   Dim cat As ADOX.Catalog, tbldb As ADOX.Table, nametbl As String
   Dim ind As ADOX.Index, varind As Variant
   Dim rst As ADODB.Recordset, fld As Field, fd As FileDialog, Itemfile As Variant
   Dim filname As String, n As Integer, m As Integer, zag() As Variant
   Dim obWord As Object, obDoc As Object, obTbl As Object
 
   Set fd = Application.FileDialog(msoFileDialogFilePicker)
   If fd.Show = -1 Then
      For Each selectfile In fd.SelectedItems
         filname = selectfile
      Next
   End If
   
   ' создание таблицы Word
   Set obWord = New Word.Application
   Set obDoc = GetObject(filname)
   If obDoc.Tables.Count = 0 Then MsgBox "Выбранный файл не содержит таблицы с данными! ", 64:  Exit Sub
   Set obTbl = obDoc.Tables(1)
   n = obTbl.Rows.Count
   m = obTbl.Columns.Count
   ReDim zag(m)
   For i = 1 To m
       zag(i) = obTbl.Cell(1, i).Range.Text       ' запоминание заголовков солбцов таблицы Word
       zag(i) = Left(zag(i), Len(zag(i)) - 2)
       zag(i) = Replace(Replace(zag(i), Chr(10), ""), Chr(13), "")
'       Debug.Print i, zag(i)
   Next i
   
  ' создание таблицы БД
    Set cat = New ADOX.Catalog
    Set tbldb = New Table
    Set ind = New ADOX.Index
    cat.ActiveConnection = CurrentProject.Connection
   
    nametbl = InputBox("Имя таблицы базы данных? ")
    tbldb.Name = nametbl
 
    tbldb.Columns.Append "ID", adInteger
    With tbldb.Columns("ID")                                    '  создание поля-счетчика
       .ParentCatalog = cat
       .Properties("AutoIncrement") = True
    End With
    '  создание первичного ключа
    ind.Name = "Index"
    ind.PrimaryKey = True
    ind.Unique = True
    ind.Columns.Append "ID", adInteger
    tbldb.Indexes.Append ind
 
    For i = 1 To m
         tbldb.Columns.Append zag(i), adVarWChar, 250    ' добавление остальных полей
    Next i
   cat.Tables.Append tbldb
   cat.Tables.Refresh
   Application.RefreshDatabaseWindow
   
   ' создание Recordset и заполнение таблицы БД
   Set rst = New ADODB.Recordset
    rst.Open nametbl, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    With obTbl
        For i = 2 To .Rows.Count
             rst.AddNew
             For j = 1 To .Columns.Count
                ' при считывании текстовых данных удаляются непечатаемые символы в конце
                 rst.Fields(j) = Left(.Cell(i, j).Range.Text, Len(.Cell(i, j).Range.Text) - 2)
             Next j
             rst.Update
             rst.MoveNext
        Next i
    End With
    rst.Close
    Set rst = Nothing
    Set cat = Nothing
    Set tbldb = Nothing
    Set ind = Nothing
    Set obWord = Nothing
    Set obDoc = Nothing
    Set obTbl = Nothing
     
End Sub