ActiveDocument.Protect Password:="", NoReset:=False, Type:= _
         wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False

Const ИмяФайлаШаблона = "шаблон.dot"
Const КоличествоОбрабатываемыхСтолбцов = 35
Const РасширениеСоздаваемыхФайлов = ".doc"

Sub СформироватьДоговоры()
     ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
     НоваяПапка = NewFolderName & Application.PathSeparator
     Dim row As Range, pi As New ProgressIndicator
     r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
     If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

     pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
     pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

'    Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
'    'Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word - почему-то замена не производится

     Dim WA As Object, WD As Object ': Set WA = New Word.Application    ' c подключением библиотеки Word
     Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word - почему-то замена не производится
     For Each row In ActiveSheet.Rows("3:" & r)
         With row
             ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(6))
             Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

             pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
             Set WD = WA.Documents.Add(ПутьШаблона): DoEvents

             pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
             For i = 1 To КоличествоОбрабатываемыхСтолбцов
                 FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
                 'FindText используем как имя закладки, содержимое которой нужно изменить
                 'При этом из этой переменной удаляем пробелы и фигурные скобки
                 FindText = Replace(FindText, " ", "")
                 FindText = Replace(FindText, "{", "")
                 FindText = Replace(FindText, "}", "")
                 UpdateBookmarks WD, FindText, ReplaceText
                 ' так почему-то заменяет не всё (не затрагивает таблицу)
                 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

                 'pi.line3 = "Заменяется " & FindText & " на " & ReplaceText: pi.FP.Repaint: DoEvents
'                With WA.Selection.Find    ' а так всё работает как надо
'                    .Text = FindText
'                    .Replacement.Text = ReplaceText
'                    .Forward = True
'                    .Wrap = wdFindContinue
'                    .Format = False: .MatchCase = False
'                    .MatchWholeWord = False
'                    .MatchWildcards = False
'                    .MatchSoundsLike = False
'                    .MatchAllWordForms = False
'                    .Execute Replace:=wdReplaceAll
'                End With
                 DoEvents
             Next i
             pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
             WD.Fields.Update 'Обновляем поля в документе
             'сохраняем документ, не добавляя его в список открытых файлов
             WD.SaveAs Filename, AddToRecentFiles:=False: WD.Close False: DoEvents
             p = p + a
         End With
     Next row

     pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
     WA.Quit False: pi.Hide
     msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
     MsgBox msg, vbInformation, "Готово"
End Sub

'Процедура обновления закладок в документе
Sub UpdateBookmarks(ByVal Doc As Object, ByVal NameOfBookmark As String, ByVal ContentOfBookmark As Variant)
     On Error Resume Next
     Dim rng As Object
     Dim bm As Object
     Set bm = Doc.Bookmarks
     Set rng = bm(NameOfBookmark).Range
     rng.Text = ContentOfBookmark
     bm.Add NameOfBookmark, rng
End Sub

Function NewFolderName() As String
     NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now)
     MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function