---

Option Explicit

Sub CreateWordDocument()

    Dim wdApp As Object
    Dim wdDoc As Object
    Dim ws As Worksheet

    Dim templatePath As String
    Dim outputPath As String

    Dim lastRow As Long
    Dim i As Long

    Dim key As String
    Dim value As String

    Set ws = ThisWorkbook.Worksheets("Лист1")

    ' Шаблон Word лежит рядом с Excel-файлом
    templatePath = ThisWorkbook.Path & "\template.docx"

    If Dir(templatePath) = "" Then
        MsgBox "Не найден шаблон Word:" & vbCrLf & _
               templatePath, vbExclamation
        Exit Sub
    End If

    ' Находим последнюю заполненную строку в колонке C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    ' Запускаем Word
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")

    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If

    On Error GoTo 0

    ' Открываем шаблон
    Set wdDoc = wdApp.Documents.Open(templatePath)

    ' Перебираем все ключи начиная с C2
    For i = 2 To lastRow

        key = Trim(CStr(ws.Cells(i, "C").Value))

        ' Если ключ пустой — пропускаем строку
        If key <> "" Then

            ' Значение берём из колонки B
            value = CStr(ws.Cells(i, "B").Value)

            ' Заменяем ключ в Word
            ReplaceWordText wdDoc, key, value

        End If

    Next i

    ' Сохраняем результат
    outputPath = ThisWorkbook.Path & "\result.docx"

    wdDoc.SaveAs2 outputPath

    ' Показываем Word
    wdApp.Visible = True

    MsgBox "Документ создан:" & vbCrLf & _
           outputPath, vbInformation

    Set wdDoc = Nothing
    Set wdApp = Nothing

End Sub


Private Sub ReplaceWordText( _
    ByVal wdDoc As Object, _
    ByVal searchText As String, _
    ByVal replaceText As String)

    With wdDoc.Content.Find

        .ClearFormatting
        .Replacement.ClearFormatting

        .Text = searchText
        .Replacement.Text = replaceText

        .Forward = True
        .Wrap = 1          ' wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False

        .Execute Replace:=2 ' wdReplaceAll

    End With

End Sub