Вставка текста из Excel в Word

Sub TablesRemovePilcrons()
Dim oTbl As Table
Dim oCll As Cell
For Each oTbl In ActiveDocument.Tables
For Each oCll In oTbl.Range.Cells
While oCll.Range.Characters.Last.Previous = Chr(13)
oCll.Range.Characters.Last.Previous = ""
Wend
Next
Next
End Sub

Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
 
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
 
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
 
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(3)) & " " & Get_Now
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
 
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
 
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
 
                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            
        With ThisWorkbook.Worksheets("Мероприятия") ' специально(!) именно ТАК, а не ActiveSheet
        r = .Cells(.Rows.Count, 1).End(xlUp).row
        If r > 1 Then
 
   
            ' копируем в буфер обмена сразу все данные, для заполнения таблицы Word
            .Cells(2, 2).Resize(r - 1, 6).Copy
            
            With WD.Tables(1)
                n = .Rows.Count
                If n < r Then
                    ' добавляем в таблицу недостающее кол-во строк
                    .Cell(n, 1).Select
                    WA.Selection.InsertRowsBelow r - n
                ElseIf n > r Then
                    ' удаляем из таблицы лишние строки
                    WD.Range(.Rows(r + 1).Range.Start, .Rows(n).Range.End).Rows.Delete
                End If
                ' вставляем из буфера
                WD.Range(.Cell(2, 2).Range.Start, .Cell(r, 7).Range.End).Paste
                ' проставляем порядковые номера
                For n = 2 To r
                    .Cell(n, 1).Range.Text = n - 1
                Next
            End With
            'WD.Save ' сохраняем заполненный документ Word, если нужно
            Application.CutCopyMode = False
        Else
            MsgBox "Нет данных для копирования в Word", vbExclamation, ThisWorkbook.Name
        End If
    End With
            
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
                       
        End With
   
    Next row
    
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Dim WA As Object, WD As Object
papka = ThisWorkbook.Path & "\шаблоны\"
dt = ThisWorkbook.Path & "\" & Replace(TextBox2, """", "")
If Len(Dir(dt, vbDirectory)) = 0 Then MkDir dt
    Set WA = CreateObject("Word.Application")
    Set WD = WA.Documents.Open(papka & "\Участники сделки.docx") ' путь ворд
WD.Range.Find.Execute FindText:="#ФИО", ReplaceWith:=TextBox9, Replace:=2 
WD.Range.Find.Execute FindText:="#ДМрожедения", ReplaceWith:=(TextBox10 & ", " & TextBox11), Replace:=2
WD.Range.Find.Execute FindText:="#МестоРождения", ReplaceWith:=TextBox11, Replace:=2
WD.Range.Find.Execute FindText:="#Гражданство", ReplaceWith:=TextBox12, Replace:=2
' и т.д.
WA.Visible = True
Application.DisplayAlerts = False
WD.SaveAs Filename:=dt & "\" & "Участники сделки.docx"
WA.Quit
'Set WA = Nothing
Application.DisplayAlerts = True
MsgBox "Документы сформированы", , "Результат {-_-}"

for i=1 to 3
WD.Range.Find.Execute FindText:="#ФИО" & i, ReplaceWith:=split(TextBox9, разделитель)(i-1), Replace:=2 
...
next

WD.Tables(1).Range.Copy ' копируем первую таблицу в буфер обмена до начала заполнения
for i=1 to количество_участников
if i>1 then
    ' вставка после таблицы из буфера - "приклеится", будет одной таблицей
    with WD.tables(1).tange
        WD.range(.end, .end).paste
    end with
end if
.... ' заполняем
next