Function ReplaceText(ByVal ID As String, ByVal TextToReplace As String) As Boolean
    Dim i As Long, MaxLen As Long
    Dim Text As String, Mark As String
    Dim iExcel As Object

    MaxLen = 200
    ' Choose a character for Mark that is not in your data,
    '  and is not a special char: ~?*
    Mark = "!"
        If ID <> vbNullString Then
            Do
                Text = Left$(TextToReplace, MaxLen) & Mark
                ' Terminate the loop when all of TextToReplace has been processed
                If Text = Mark Then Text = vbNullString
                TextToReplace = Mid$(TextToReplace, MaxLen + 1)
                iExcel.Sheets(1).Replace _
                What:=ID, _
                Replacement:=Text
                ID = Mark
            Loop Until Text = vbNullString
        End If
End Function

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
Dim iExcel As Object

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

'перебираем массив
For i = 2 To iRow
    If MyArray(i, 1) = "ok" Then
    
        'перебираем указанные excel-шаблоны
            tmpSTR = iFolder & tmpArray(q) & ".xlsx"
                If Len(Dir(tmpSTR)) > 0 Then
                    Set iExcel = Workbooks.Open(tmpSTR)
                    'делаем замену переменных
                     For j = 4 To iColl
                        iExcel.Sheets(1).Cells.Replace MyArray(1, j), MyArray(i, j)
                        'Call ReplaceText(MyArray(1, j), MyArray(i, j))
                    Next j
                    
                    iExcel.SaveAs Filename:=BasePath & MyArray(i, 2) & " - " & tmpArray(q) & ".xlsx" '".docx" ', FileFormat:=wdFormatXMLDocument
                    iExcel.Close False: Set iExcel = Nothing
                End If