---

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 folderName As String
    Dim baseName As String

    Dim lastRow As Long
    Dim i As Long

    Dim key As String
    Dim value As String

    Set ws = ThisWorkbook.Worksheets("КДВ")

    ' Путь к шаблону Word
    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)
            ' Для переноса строки в ворде
            value = Replace(value, vbLf, Chr(11))
            ' Замена ключа в Word
            ReplaceWordText wdDoc, key, value

        End If

    Next i

    ' Сохранение результата
    baseName = CStr(ws.Range("B6").value)
    folderName = Left(baseName, 4) & "XXXX" & Mid(baseName, 9)
    
    ' Создаем папку
    If Dir(ThisWorkbook.Path & "\" & folderName, vbDirectory) = "" Then
        MkDir ThisWorkbook.Path & "\" & folderName
    End If
        
    
    outputPath = ThisWorkbook.Path & "\" & folderName & "\" & CStr(ws.Range("B6").value) & ".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