---

Option Explicit

Sub AutocompleteDocs()

    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)

            ' Ïåðåíîñ ñòðîêè äëÿ Word
            value = Replace(value, vbLf, Chr(11))

            ' Çàìåíà êëþ÷åé
            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

    ' Çàêðûòèå ïåðâîãî äîêóìåíòà
    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)

            ' Ïåðåíîñ ñòðîêè äëÿ Word
            value = Replace(value, vbLf, Chr(11))

            ' Çàìåíà êëþ÷à
            ReplaceWordText wdDoc2, key, value

        End If

    Next i

    ' ==========================================
    ' Ñîõðàíåíèå âòîðîãî äîêóìåíòà
    ' ==========================================

    outputPath2 = ThisWorkbook.Path & "\" & _
                  folderName & "\" & _
                  CStr(ws.Range("B16").value) & ".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