Const ИмяФайлаШаблона = "шаблон3.dot"
Const КоличествоОбрабатываемыхСтолбцов = 8
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
   Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word

   For Each row In ActiveSheet.Rows("3:" & r)
       With row
           ФИО = Trim$(.Cells(1)) & "" & Trim$(.Cells(2))
           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))

               ' так почему-то заменяет не всё (не затрагивает таблицу)
               'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

               pi.line3 = "Заменяется поле " & FindText
               With WD.Range.Find
                   .Text = FindText
                   .Replacement.Text = ReplaceText
                   .Forward = True
                   .Wrap = 1
                   .Format = False: .MatchCase = False
                   .MatchWholeWord = False
                   .MatchWildcards = False
                   .MatchSoundsLike = False
                   .MatchAllWordForms = False
                   .Execute Replace:=2
               End With
               DoEvents
           Next i
           pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
           WD.SaveAs Filename: 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










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