Set Rng = Document.Range
    With Rng
        .Collapse wdCollapseEnd
        ' таблица, из запроса 
        .InsertDatabase , , _
            Connection:= "qWordDog" , _
            DataSource:=Application.CurrentProject.Path &  "\"  & Application.CurrentProject.name

  Dim WordApp As Word.Application
  Dim Rng As Word.Range
  Dim tbl As Word.Table
.....
'создадим табличку
    With WordApp.Selection.Find
        .Text = "с реестром:"
        .Replacement.Text = ""
        .Forward = True
    End With
    WordApp.Selection.Find.Execute
    WordApp.Selection.EndKey Unit:=wdLine
    WordApp.Selection.TypeParagraph
Set Rng = Document.Range
    With Rng
        .Collapse wdCollapseEnd
        ' таблица, из запроса 
        .InsertDatabase _
            Style:= 191 , _
            LinkToSource:=False, _
            Connection:= "Query qveksWordDog" , _
            DataSource:=CurrentDb.name
        i = .Tables.Count 
        Set tbl = .Tables(i) 
        tbl.Columns.Add tbl.Columns( 1 ) ............

  strPath = DLookup( "[dogKuda]" ,  "tbPuti" ,  "[id] = 1 ")
  strPath = strPath & date &  "Договор№"  & rs.Fields( "ndogovor" ) &  ".doc" 
  Document.SaveAs strPath
...........