Excel VBA Создать Word документы по списку из excel

Прилетела задача:

Имеем таблицу с колонками (допустим ФИО, контакты, кой какие данные)
Нужно для каждой строки создать отдельный Word документ по шаблону и заполнить данными из строки. Шаблоны могут быть разными.

В общем задача в голове разворачивается, я понимаю как ее сделать теми методами, что чаще использую - 1С. Но задачу надо решить силами Excel. Так как план работы "программы" есть, остается дело за малым - выразить его в VBA. Да, занимает чуть дольше, так как я практически не использую данный язык и приходится спрашивать у гугла - "как описывается цикл" и прочее, но результатом заказчик доволен.

К чему мы пришли:

• В первой строке у колонок с нужными данными должны быть уникальные названия латиницей.
• Обязательно должен быть столбец KeyWord, в нем содержится ключевой слово для определения текущего шаблона (Template_%KeyWord%.docx)
• Также должен быть столбец FIO, и должен быть заполнен, иначе строка будет пропущена 
• Шаблон должен находится в папке с файлом excel с макросом
• В шаблоне используем "элемент управления содержимым". Название его соответствует названию колонки в excel документе

Если при работе программы элемент не будет найден, то он будет пропущен.

Все, дальше добавляем кнопку в excel документ и связываем его с этим макросом, все должно работать. Будут созданы файлы "Act %KeyWord%.docx" с необходимым заполнением. 

Sub CreateDocuments()
    
    Dim KeyWordFound As Boolean
    KeyWordFound = False
    
    Dim lColumn As Long, lRow As Long
    lColumn = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
    lRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
    
    Dim CurrentKeyWord As String, CurrentPath As String, FileTemplateName As String, NewFileName As String
    
    Dim collWordVariable As New Collection
    
    
    Dim RangeWithData As Range, RangeNameVar As Range, Rows As Range
    Set RangeNameVar = ActiveSheet.Range(ActiveSheet.Cells(1, 1).Address, ActiveSheet.Cells(1, lColumn).Address)
    Set RangeWithData = ActiveSheet.Range(ActiveSheet.Cells(1, 1).Address, ActiveSheet.Cells(lRow, lColumn).Address)
    
    Dim objWord As Object, objDoc As Object
    
    
    CurrentPath = Application.ActiveWorkbook.Path
    
    'get names of variables. variable names must be listed on the first line of the file as a column name. we will use these names for fill template file.
    For Each cell In RangeNameVar
       If Len(cell.Value) > 0 Then
        collWordVariable.Add cell.Column, cell.Value
        If cell.Value = "KeyWord" Then
            KeyWordFound = True
        End If
        'Debug.Print cell.Value
       End If
    Next
    
    If KeyWordFound = False Then
        MsgBox "Field KeyWord not found!"
        GoTo EOF
    End If
    
    For Each Row In RangeWithData.Rows

       'Checking the completion of the KeyWord field
       CurrentKeyWord = ActiveSheet.Cells(Row.Row, collWordVariable("KeyWord")).Value
       If Len(CurrentKeyWord) = 0 Then GoTo ContinueLoopFirst
       
       'Checking the existence of a template file
       FileTemplateName = CurrentPath & "\Template_" & CurrentKeyWord & ".docx"
       If Len(Dir(FileTemplateName)) = 0 Then
        'Debug.Print FileTemplateName & " not found"
        GoTo ContinueLoopFirst
       End If
       
       'If filed FIO is empty, we need to go to next line
       CurrentVarFIO = ActiveSheet.Cells(Row.Row, collWordVariable("FIO")).Value
       If Len(CurrentKeyWord) = 0 Then GoTo ContinueLoopFirst
       
       NewFileName = CurrentPath & "\Act " & CurrentVarFIO & " " & CurrentKeyWord & ".docx"
       
       FileCopy FileTemplateName, NewFileName
        
       If Len(Dir(NewFileName)) > 0 Then
           Set objWord = CreateObject("Word.Application")
           Set objDoc = objWord.Documents.Open(NewFileName)
           'objWord.Visible = True

            For Each field In collWordVariable
                'Debug.Print collWordVariable(i).Name
                CurrentKeyWord = ActiveSheet.Cells(1, field).Value
                'Debug.Print fiel & " " & CurrentKeyWord
                
                On Error Resume Next
                objDoc.SelectContentControlsByTag(CurrentKeyWord).Item(1).Range.Text = Row.Cells(1, field)
            Next
            ActiveSheet.Cells(Row.Row, lColumn + 1).Value = "OK"
           objDoc.Save
           objDoc.Close
        Else
        MsgBox NewFileName & " not found"
       End If
        
ContinueLoopFirst:
    Next
MsgBox "Program END!"
On Error Resume Next
objWord.Quit
EOF:
End Sub