Удобное заполнение Word из Excel

Sub CreateWordFile()
 Dim filePath As String
 Dim data As Collection
 Dim headersRow As Integer
 headersRow = 1
 filePath = SelectWordTemplate()
 If filePath <> "" Then
  Set data = GetSelectedData(headersRow)
  Call CreateAndFillWordDocument(filePath, data)
 End If
End Sub
 
Function SelectWordTemplate() As String
Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Title = "Select a Word Template"
        .Filters.Add "Word Files", "*.dotx;*.docx;*.docb;*.doc", 1
        .AllowMultiSelect = False
        If .Show = True Then
            SelectWordTemplate = fd.SelectedItems(1)
        End If
    End With
End Function
 
Function GetSelectedData(headerRowIndex As Integer) As Collection
 Set GetSelectedData = New Collection
 Dim cell As Range
 Dim cellValue As String
 Dim cellKey As String
 Dim emptyCellCounter As Integer
 emptyCellCounter = 0
 For Each cell In Selection
      cellValue = cell.Value2
      cellKey = cell.Worksheet.Cells(headerRowIndex, cell.Column).Value2
      GetSelectedData.Add Array(cellKey, cellValue)
      If cellValue = "" Then
        emptyCellCounter = emptyCellCounter + 1
      Else
        emptyCellCounter = 0
      End If
      If emptyCellCounter > 100 Then
        Exit Function
      End If
 Next cell
End Function
 
Sub CreateAndFillWordDocument(file As String, data As Collection)
Set wApp = CreateObject("Word.Application")
wApp.DisplayAlerts = False
Dim wDoc As Object
Set wDoc = wApp.Documents.Add(Template:=file, NewTemplate:=False, DocumentType:=0)
Call FillWordDocument(wDoc, data)
wApp.DisplayAlerts = True
wApp.Visible = True
End Sub
 
Sub FillWordDocument(wDoc As Object, data As Collection)
Dim key As Variant
 For i = 1 To data.count
   Dim text As String
   Dim replace As String
   Dim content As String
   text = "{%" & data.Item(i)(0) & "%}"
   replace = data.Item(i)(1)
   Set myRange = wDoc.content
   myRange.Find.Execute FindText:=text, ReplaceWith:=replace
Next i
End Sub