Sub Печать()
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Sheets("Реестр доверенностей").Select
    Range("B2:D2").Select
    Selection.Copy
    Cells(ActiveCell.Row, 1).Resize(, 9).Copy Cells(Rows.Count, 1).End(xlUp)(2)
    Range("B2").Select
    Application.CutCopyMode = False
    Range("A3:D3").Select
    Sheets("Доверенность").Select
    Range("U1").Select
End Sub

Option Explicit
Option Private Module

Public AppWord As Word.Application, iWord As Word.Document



Sub CreateDoc()
Dim MyArray(), BasePath As String, iFolder As String, iTemplate As String
Dim tmpArray, tmpSTR As String, iRow As Long, iColl As Long, i As Long, j As Long, q As Long

Application.ScreenUpdating = 0
On Error GoTo iEnd

iFolder = Range("FILE_WORD").Value: If Right(iFolder, 1) <> "\" Then iFolder = iFolder & "\"
iTemplate = Range("FILE_TEMPLATE").Value: If Right(iTemplate, 1) = ";" Then iTemplate = Left(iTemplate, Len(iTemplate) - 1)
BasePath = ThisWorkbook.Path & "\Result\": Call FolderCreateDel(BasePath)

With Sheets("data")
    iRow = .UsedRange.Row + .UsedRange.Rows.Count - 1: iColl = .UsedRange.Column + .UsedRange.Columns.Count - 1
    MyArray = .Range(.Cells(1, 1), .Cells(iRow, iColl)).Value
End With

'создаем скрытый объект Word
Set AppWord = CreateObject("Word.Application"): AppWord.Visible = False

'перебираем массив
For i = 2 To iRow
    If MyArray(i, 1) = "ok" Then
    
        'перебираем указанные word-шаблоны
        tmpArray = Split(MyArray(i, 3), ";")
        For q = 0 To UBound(tmpArray)
            tmpSTR = iFolder & tmpArray(q) & ".docx"
            If Len(Dir(tmpSTR)) > 0 Then
                Set iWord = AppWord.Documents.Open(tmpSTR, ReadOnly:=True)
            
                'делаем замену переменных
                For j = 4 To iColl
                    Call ExportWord(MyArray(1, j), MyArray(i, j))
                Next j
                
                iWord.SaveAs Filename:=BasePath & MyArray(i, 2) & " - " & tmpArray(q) & ".docx", FileFormat:=wdFormatXMLDocument
                iWord.Close False: Set iWord = Nothing
            End If
            'tmpSTR = ""
        Next q
        'Erase tmpArray

    End If
Next i

AppWord.Quit: Set AppWord = Nothing
'Erase MyArray: BasePath = "": iFolder = "": iTemplate = ""

Application.ScreenUpdating = 1
MsgBox "Файлы сформированы.", vbInformation

Exit Sub

iEnd:
    AppWord.Quit: Set AppWord = Nothing
    'Erase MyArray: BasePath = "": iFolder = "": iTemplate = ""
    Application.ScreenUpdating = 1
    MsgBox "При обработке данных возникла ошибка.", vbCritical
End Sub