---

Option Explicit

Sub CreateWordDocument()

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

    Dim templatePath As String
    Dim templatePath2 As String

    Dim outputPath As String
    Dim outputPath2 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"
    templatePath2 = ThisWorkbook.Path & "\template2.docx"

    ' Проверяем первый шаблон
    If Dir(templatePath) = "" Then
        MsgBox "Не найден шаблон Word:" & vbCrLf & _
               templatePath, vbExclamation
        Exit Sub
    End If

    ' Проверяем второй шаблон
    If Dir(templatePath2) = "" Then
        MsgBox "Не найден второй шаблон Word:" & vbCrLf & _
               templatePath2, 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)

    ' ==========================================
    ' Заполняем первый документ
    ' ==========================================

    For i = 2 To lastRow

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

        If key <> "" Then

            value = CStr(ws.Cells(i, "B").Value)

            ' Перенос строки Excel -> перенос строки Word
            value = Replace(value, vbLf, Chr(11))

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

        End If

    Next i

    ' ==========================================
    ' Создаём папку
    ' ==========================================

    baseName = CStr(ws.Range("B6").Value)

    ' Заменяем символы с 5-го по 8-й
    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

    ' Закрываем первый документ
    wdDoc.Close SaveChanges:=False

    Set wdDoc = Nothing

    ' ==========================================
    ' Открываем второй шаблон
    ' ==========================================

    Set wdDoc2 = wdApp.Documents.Open(templatePath2)

    ' ==========================================
    ' Заполняем второй документ
    ' ==========================================

    For i = 2 To lastRow

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

        If key <> "" Then

            value = CStr(ws.Cells(i, "B").Value)

            ' Перенос строки Excel -> перенос строки Word
            value = Replace(value, vbLf, Chr(11))

            ' Замена ключа
            ReplaceWordText wdDoc2, key, value

        End If

    Next i

    ' ==========================================
    ' Сохраняем второй документ
    ' ==========================================

    outputPath2 = ThisWorkbook.Path & "\" & _
                  folderName & "\" & _
                  CStr(ws.Range("B6").Value) & "_2.docx"

    wdDoc2.SaveAs2 outputPath2

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

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

    Set wdDoc2 = 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