WD.ActiveDocument.Protect _                
    Password:="123456", _                
    NoReset:=False, _                
    Type:=wdAllowOnlyFormFields, _                
    UseIRM:=False, _                
    EnforceStyleLock:=False

WD.SaveAs Filename: WD.Close False: DoEvents

Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") 'без подключения библиотеки Word

Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word

Const ИмяФайлаШаблона = "шаблон.dot"
Const КоличествоОбрабатываемыхСтолбцов = 11
Const РасширениеСоздаваемыхФайлов = ".doc"
Sub СформироватьДоговоры2()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "C").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(3)) & " " & Trim$(.Cells(4)) & " " & Trim$(.Cells(5))
            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

InStr(Cells(2, 1), like "*20##*")

Cells(1, 3) = Replace((Cells(1, 2)), Chr(10) & Split(Cells(1, 1))(0), "-" & Split(Cells(1, 1))(0))

InStr(Cells(2, 1), "20##")

Cells(1, 3) = Replace((Cells(1, 2)), Chr(10) & Split(Cells(1, 1)), "-" & Split(Cells(1, 2)))

Cells(1, 3) = Replace((Cells(1, 2)), "Chr(10) & Split(Cells(1, 1))", "- & Split(Cells(1, 2))")

.MatchWildcards = True

.Execute Replace:=2

            FindText = "{*}": ReplaceText = ""
            
                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

            FindText = "{*}": ReplaceText = ""
            
                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

            For i = 1 To 15

                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))

                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = True: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With

                DoEvents
            Next i

Sub test()

    Dim iLastRowA As Long
    iLastRowA = Worksheets("1").Cells(Rows.Count, 1).End(xlUp).Row

    Dim lLastRowB As Long
    iLastRowB = Worksheets("2").Cells(Rows.Count, 1).End(xlUp).Row

    Dim i As Long
    Dim j As Long
    Dim x As String

    For i = 2 To iLastRowA

        x = Worksheets("1").Cells(i, 1)

            For j = 2 To iLastRowB

                If Worksheets("2").Cells(j, 1) Like x And Worksheets("2").Cells(j, 2) = "да" Then

                   Worksheets("1").Cells(i, 2) = Worksheets("1").Cells(i, 2) + 1

                End If

            Next

    Next

End Sub

Cells(i, 2) = Left(Cells(i, 1), InStrRev(Cells(i, 1), "///"))

Mid(строка, начало, [длина])

Cells(i, 3) = Mid(Cells(i, 1), (InStrRev(Cells(i, 1), "///")))

Sub test()

Dim i As Long
Dim iLastRow As Long

iLastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To iLastRow    
    Cells(i, 2) = Left(Cells(i, 1), InStrRev(Cells(i, 1), "///"))
    Cells(i, 3) = Mid(Cells(i, 1), InStrRev(Cells(i, 1), "///"))   
Next

End Sub

Cells(i, 3) = Mid(Cells(i, 1), InStrRev(Cells(i, 1), "///"))