Sub Otchet()
Dim objWord As Word.Application
Dim objDocument As Word.Document
Dim iLastRow As Long

iLastRow = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
Se t objDocument = objWord.Documents.Open(Filename:="C:\Справка\spravka.docx", ReadOnly:=False)
Set myRange = objDocument.Content

FName = "C:\Справка" & "\" & Sheets(1).Cells(8, 16).Value & "_" & Sheets(1).Cells(10, 16).Value
 
myRange.Find.ClearFormatting

   For i = 1 To iLastRow
myRange.Find.Execute FindText:="z" & i, MatchWholeWord:=True, ReplaceWith:=Sheets(4).Cells(i, 1).Text, Replace:=wdReplaceAll
    Next i

objWord.Visible = False
objDocument.SaveAs Filename:=FName & ".doc", FileFormat:=wdFormatDocument
objDocument.Close

Set myRange = Nothing
Set objDocument = Nothing
Set objWord = Nothing
End Sub

Public Function SqlFin(ByVal strSql$, ByVal FilePath$, ByVal OutputRange As Range, _
ByVal FieldsName As Boolean, ByVal OutputFieldsName As Boolean)
'==============================================================================
'*Описание функции : Возвращает набор записей Recordset с первой ячейки адреса,
'* указанного диапазона.
'*strSql - Конструкция SQL  запроса.
'* FilePath - Полный путь к файлу включая имя и расширение.
'* OutputRange - адрес ячеки с которой начинается вывод данных.
'* FieldsName - используются или нет заголовки столбцов (True - False)
'* OutputFieldsName - вывод данных с заголовками или без (True - False), _
'* если FieldsName=False, заголовки не выводятся.

Dim sCon As String, FieldName As String
Dim rs As Object, cn  As Object
Set rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.Connection")
If FieldsName Then FieldName = "Yes" Else FieldName = "No"
Select Case CLng(Split(Application.Version, ".")(0))
    Case Is < 12
        sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FilePath _
          & ";Extended Properties=""Excel 8.0;HDR=" & FieldName & ";IMEX=1"";"
    Case Is >= 12
        sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath _
        & ";Extended Properties=""Excel 12.0;HDR=" & FieldName & ";IMEX=1"";"
End Select

cn.Open sCon
If Not cn.State = 1 Then Exit Function
Set rs = cn.Execute(strSql)
If Not FieldsName Then OutputFieldsName = False
 If OutputFieldsName Then
    For i = 0 To rs.Fields.Count - 1
    OutputRange.Offset(0, i) = rs.Fields(i).Name
    Next
    Set OutputRange = OutputRange.Offset(1, 0)
 End If
 DoEvents
OutputRange.CopyFromRecordset rs
rs.Close:  cn.Close
Set cn = Nothing: Set rs = Nothing
End Function