=ИНДЕКС(Таблица1[Автор];НАИМЕНЬШИЙ(ЕСЛИ((Лист2!$A$1=Таблица1[Автор])*(Лист2!$C$1=Таблица1[Отметка о выплате]);СТРОКА(Таблица1[Автор])-СТРОКА(Таблица1[[#Заголовки];[Автор]]);30);СТРОКА(ДВССЫЛ("A1:A"&ЧСТРОК(Таблица1[Автор])))))

With .Content.Find
   .Text = "#CitationPlaceholder#"
   .Replacement.Text = citeEn 'не больше 255 символов
   .Execute Replace:=wdReplaceAll
End With

Selection.Find.ClearFormatting
Selection.Find.Execute FindText:="#CitationPlaceholder#", Wrap:=wdFindContinue
If Selection.Find.Found = True Then Selection.Text = citeEn 'много символов

Сonst ИмяФайлаШаблона = "Шаблон Протокола.dot"
 КоличествоОбрабатываемыхСтолбцов = 11
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 - 62
   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("63:" & r)
 With row
     ИмяПротокола = Trim$(.Cells(10))
     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(61, 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, "Готовые протоколы по службам")
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