Сохранение заполненного шаблона word данными из access

Private Sub pasport2_Click()
If Me!spisok1 = 0 Then
MsgBox "Не выбран номер обращения в списке!"
Exit Sub
End If
''On Error GoTo Err_pasport1_Click
Err.Number = 0
On Error GoTo notloaded
Set app = GetObject(, "Word.Application")
notloaded:
If Err.Number = 429 Then
Err.Clear
Set app = CreateObject("Word.Application")
theError = Err.Number
End If
app.Visible = True
On Error GoTo Err_pasport2_Click
With app
Set myDoc = .Documents.Add("c:\Gens\dot\Паспорт_2.dot")
Set MyRange = myDoc.Content
MyRange.Find.Execute FindText:="%Номер_образца%", ReplaceWith:=Format(Me!spisok1.Column(3)), Replace:=wdReplaceAll
MyRange.Find.Execute FindText:="%ФИО%", ReplaceWith:=Format(Me!spisok1.Column(1)), Replace:=wdReplaceAll
MyRange.Find.Execute FindText:="%дата_завершения_выделения%", ReplaceWith:=Format(Me!spisok1.Column(23)), Replace:=wdReplaceAll
End With
Call funOutputTableWordQuery3(strPathDot, strPathWord)
Exit_pasport2_Click:
Exit Sub
Err_pasport2_Click:
MsgBox Err.Description
Resume Exit_pasport2_Click
End Sub

Function funOutputTableWordQuery3(strPathDot As String, strPathWord As String) As Boolean  'функция для заполнения таблицы шаблона ворд из запроса
'On Error GoTo Err_
Dim i_ As Long
i_ = 0
Set dbs = CurrentDb()
Debug.Print dbs.Name
s1 = dbs.QueryDefs("zzz2").SQL
Debug.Print s1
s1 = Replace(s1, "[код обращения]", Me!spisok1)
Debug.Print s1
 
'select * from
Set rst = dbs.OpenRecordset(s1) 'открываем запрос для перебора столбцов
 
rst.MoveLast 'переходим в конец набора строк - тем самым они гарантированно загружаются в переменную rstTable
CountRec = rst.RecordCount 'определяем число строк в запросе
'MsgBox CountRec
With app.ActiveWindow.Selection 'ставим фокус на текущее окно
If CountRec > 0 Then 'смотрим, чтоб не пустой запрос
'rst.MoveLast 'переходим в конец набора строк - тем самым они гарантированно загружаются в переменную rstTable
 rst.MoveFirst 'возращаемся в начало набора строк
If TrueBookmark("NZ", .Document) Then 'если есть закладка в вордовском шаблоне NZ
 .GoTo What:=wdGoToBookmark, Name:="NZ" 'Перейти на закладку NZ - начало втыкания данных в таблицу
End If
 'запоминаем номер строки таблицы где стоит начальная закладка
j = .Information(wdEndOfRangeRowNumber)
 'If CountRec > 1 Then
 'Вставим необходимое количество строк
'.InsertRowsBelow CountRec - 1 '########################################################################
' End If
 'Заполняем таблицу данными из запроса
NumStr = 1
 Do While Not rst.EOF 'Запускаем цикл перебора столбцов запроса
For i = 0 To rst.Fields.Count - 1
 'MsgBox (rst.Fields(i).Name)
 If rst.Fields(i).Name = "NumStr" Then 'если в запросе будет столбец с именем NumStr - то вместо него в ячейку таблицы встанет порядковый номер записи
.Tables(1).Cell(j, i + 1).Range = NumStr
 
 Else
 'Заполняем таблицу по координатам: номер столбца, номер строки
.Tables(1).Cell(j, i + 4).Range = Nz(rst.Fields(i), "")
 
 End If
 
 Next i
 
 i_ = i_ + 1
 If CountRec = i_ Then
 rst.Close
 GoTo hare
 End If
 
 rst.MoveNext 'переходим на следующую запись
NumStr = NumStr + 1 'увеличиваем номер по порядку
 
j = j + 1 'увеличиваем номер координаты ячейки (номер столбца)
 
Loop
 
 End If
 rst.Close 'закрываем рекордсет - при этом автоматически уничтожается и перенменная rstTable
 End With
 
hare:
 funOutputTableWordQuery3 = True 'ставим флаг успешного выполнения функции
Exit_:
 Exit Function
Err_:
 funOutputTableWordQuery3 = False
 Err.Clear
 Resume Exit_
End Function

Option Compare Database
'Option Explicit
Dim d1 As Date
Dim il As Long
Dim appWD As Word.Application
Dim MyRange As Variant
Dim app As Word.Application, strPathDot As String, strPathWord As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim que As DAO.QueryDef
Dim i As Long, j As Long, NumStr As Long, s1
Dim CountRec As Long

strPathDot="c:\Gens\dot\Паспорт_2.dot"
strPathWord .................................

Dim strPathWord
strPathWord="c:\Gens\Паспорт_2.doc"  'или .docx. Это уж как требуется 
ActiveDocument.SaveAs strPathWord

strPathWord="c:\Gens\" & me.fio & "_" & me.data_rojd & ".doc"  'или .docx. Это уж как требуется 
ActiveDocument.SaveAs strPathWord

strPathWord = CurrentProject.Path & Me.Краткое_наименование & ".doc"
ActiveDocument.SaveAs strPathWord