Sub s1()
 Dim tdoc As Document
 Dim par As Paragraph
 Dim tbl As Table
 Dim i, j, N, M As Integer
 Dim str1, str2, str3 As String
 Dim num As Double
' Dim int1 As Long
 Dim dat1 As Date
 Dim cl As Cell
 Dim vr As Variant
'база данных, требуется подключить microsoft activex data objects
 Dim cntstr As String
 Dim cnt As ADODB.Connection
 Dim cmd As New ADODB.Command
 Dim rst As New ADODB.Recordset
 Dim tb_cr As String
 Dim fld As ADODB.Field
 Dim flds( 3 ) As String
 Dim vals( 3 ) As Variant

 'подключение к каталогу
 cntstr = "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=D:\;" & _
  "Mode=Share Deny None;Extended Properties=""dbase III;"";Jet OLEDB:System database="""";" & _
  "Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";" & _
  "Jet OLEDB:Engine Type=16;Jet OLEDB:Database Locking Mode=0;" & _
  "Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;" & _
  "Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;" & _
  "Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;" & _
  "Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"
 
 Set cnt = New ADODB.Connection
 cnt.Open cntstr
 'создание таблицы
 cnt.Execute "create table tbl8 (FAMILY VARCHAR(20),AGE DOUBLE, DBTH DATE)"
 'открытие созданной таблицы
 rst.Open "tbl8", cnt, adOpenKeyset, adLockOptimistic

 Set tdoc = ThisDocument
 Set par = tdoc.Paragraphs(1)
' i = tdoc.Tables.Count
 'MsgBox (i)
 Set tbl = tdoc.Tables(1)
 N = tbl.Columns.Count
 M = tbl.Rows.Count
 For i = 2 To M
  'текстовое поле
  Set cl = tbl.Cell(i, 1)
  str1 = cl.Range.Text
  str1 = Mid(str1, 1, Len(str1) - 2)
  'MsgBox (str1)
  'числовое поле (веществ.)
  Set cl = tbl.Cell(i, 2)
  str2 = cl.Range.Text
  str2 = Mid(str2, 1, Len(str2) - 2)
  num = Val(str2)
  'числовое поле (целое)
  Set cl = tbl.Cell(i, 3)
  str3 = cl.Range.Text
  str3 = Mid(str3, 1, Len(str3) - 2)
  dat1 = DateValue(str3) 'cdate(str3)
'  MsgBox (str1 + ": " + Format(num, "#### 0 . 00 ") + ", " + Format(dat1, "dd mm yyyy"))
  
  'сохранение выбранных данных в таблицу
  rst.AddNew
  rst.Fields("family").Value = str1
  rst.Fields("age").Value = num
  rst.Fields("dbth").Value = dat1
  rst.Update
  
 Next i
 rst.Update
 rst.Close
End Sub