Как заполнить таблицу в одном документе Word данными из таблицы Excel?

Sub main()
Dim wdApp As Object
Dim wdDoc As Object
 
HomeDir$ = ThisWorkbook.Path
Set wdApp = CreateObject("Word.Application")
i% = 2
Do
If Cells(i%, 1).Value = "" Then Exit Do
If Cells(i%, 1).Value <> "" Then
 
NPP$ = Cells(i%, 1).Text
ID$ = Cells(i%, 2).Text
Adress$ = Cells(i%, 3).Text
SN$ = Cells(i%, 4).Text
 
DataC$ = Date
 
FileCopy HomeDir$ + "\template.doc", HomeDir$ + "\" + NPP$ + "_" + ID$ + "_" + DataC$ + ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir$ + "\" + NPP$ + "_" + ID$ + "_" + DataC$ + ".doc")
 
wdDoc.Range.Find.Execute FindText:="&date", ReplaceWith:=DataC$
 
wdDoc.Range.Find.Execute FindText:="&id", ReplaceWith:=ID$
wdDoc.Range.Find.Execute FindText:="&adress", ReplaceWith:=Adress$
wdDoc.Range.Find.Execute FindText:="&sn", ReplaceWith:=SN$
 
wdDoc.Save
wdDoc.Close
End If
 
i% = i% + 1
Loop
wdApp.Quit
MsgBox "Готово!"
 
End Sub

Option Explicit
 
Global WA As Object, WD As Object
 
Global Const template As String = "Form_All.docx"
 
Sub MakeDocs(flagPrint As Integer)
   Const wdExportFormatPDF As Integer = 17, _
         wdExportOptimizeForOnScreen As Integer = 1, _
         wdExportAllDocument As Integer = 0, _
         wdExportDocumentContent As Integer = 0, _
         wdExportCreateNoBookmarks As Integer = 0
   Dim i As Integer, OutDoc As String, OutPath As String, _
       Age As Integer, suffix As String, sAddr As String, sExt As String
 
   If Dir(ThisWorkbook.Path & "\" & template) = "" Then
      Call MsgBox("Нет файла шаблона " & template, vbCritical + vbOKOnly, "Внимание!")
      Exit Sub
   End If
 
   Application.ScreenUpdating = False
   On Error Resume Next
   Set WA = GetObject(, "Word.Application")
   If WA Is Nothing Then Set WA = CreateObject("Word.Application")
 
   Set WD = WA.Documents.Open(Filename:=ThisWorkbook.Path & "\" & template)
 
   ' Page 1 - Russian
   Call FieldReplace("{DATE}", frmWork.dtForm.Caption)                     ' Справка от
   Call FieldReplace("{NAME_R}", frmWork.txtFIO.Text)                      ' ФИО
   Call FieldReplace("{GENDER_R}", frmWork.cbSex.Value)                    ' Пол
   Call FieldReplace("{DOB}", frmWork.dtBirth.Caption)                     ' Дата рождения
   Call FieldReplace("{ADDR_R}", frmWork.txtReg.Text)                      ' Адрес регистрации
   Call FieldReplace("{TEST_R}", frmWork.cbTestRus.Value)                  ' Наименование теста
   Call FieldReplace("{DT_GET}", frmWork.dt_Get.Caption)                   ' Дата взятия биоматериала
   Call FieldReplace("{DT_TST}", frmWork.dt_Exc.Caption)                   ' Дата выполнения теста
   Call FieldReplace("{RES_R}", frmWork.cbRes.Value)                       ' Результат теста
   Call FieldReplace("{POS_R}", frmWork.lblPos.Caption)                    ' Должность врача
   Call FieldReplace("{DOCT_R}", GetInit(frmWork.cbDoctor.Value))          ' ФИО доктора
   
   Application.StatusBar = "Сохранение файла..."
 
   OutPath = frmWork.txtOut.Text
   OutDoc = OutPath & "\" & Replace(Replace(Replace(frmWork.txtFIO.Text & " " & frmWork.dtForm.Caption, " ", "_"), ".", "_"), ":", "_")
   WD.ExportAsFixedFormat OutputFileName:=OutDoc, ExportFormat:=wdExportFormatPDF, _
      OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForOnScreen, _
      Range:=wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
      IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
      DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
 
   WD.Close SaveChanges:=False
 
   WA.Quit False
 
   Set WD = Nothing
   Set WA = Nothing
End Sub
 
Private Sub FieldReplace(s1 As String, s2 As String)
   Application.StatusBar = "Замена " & s1 & " на " & s2 & "..."
   WD.Activate
   With WA.Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = s1
      .Replacement.Text = s2
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
   End With
End Sub

WD.Tables(1).Rows.Add   ' добавить строку (позднее снять закраску в шаблонах!)
iNum = iNum + 1         ' номер строки
' далее в зависимости от шаблона (несколько отличаются)
Select Case templ ' 1-2-3 можно вынести, но пусть тут будет полное описание
   Case "Шаблон_трансфер.docx"
        WD.Tables(1).Rows(iNum).Cells(1).Range.Text = iNum - 1               ' N
        WD.Tables(1).Rows(iNum).Cells(2).Range.Text = .Cells(i, "A").Text    ' Дата
        WD.Tables(1).Rows(iNum).Cells(3).Range.Text = .Cells(i, "B").Text    ' Время
        sTmp = .Cells(i, "D")
        If dicAddr.Exists(CStr(.Cells(i, "D"))) Then sTmp = dicAddr.Item(CStr(.Cells(i, "D")))
        WD.Tables(1).Rows(iNum).Cells(4).Range.Text = sTmp                   ' Адрес подачи
        sTmp = .Cells(i, "E")
        If dicAddr.Exists(CStr(.Cells(i, "E"))) Then sTmp = dicAddr.Item(CStr(.Cells(i, "E")))
        WD.Tables(1).Rows(iNum).Cells(5).Range.Text = sTmp                   ' Адрес назначения
        WD.Tables(1).Rows(iNum).Cells(6).Range.Text = .Cells(i, "F").Text    ' Сумма
        WD.Tables(1).Rows(iNum).Cells(7).Range.Text = MSumProp(.Cells(i, "F"))  ' Сумма прописью
 
   Case "Шаблон_курьер.docx"
        WD.Tables(1).Rows(iNum).Cells(1).Range.Text = iNum - 1               ' N
        WD.Tables(1).Rows(iNum).Cells(2).Range.Text = .Cells(i, "A").Text    ' Дата
        WD.Tables(1).Rows(iNum).Cells(3).Range.Text = .Cells(i, "B").Text    ' Время
        sTmp = .Cells(i, "D")
        If dicAddr.Exists(CStr(.Cells(i, "D"))) Then sTmp = dicAddr.Item(CStr(.Cells(i, "D")))
        WD.Tables(1).Rows(iNum).Cells(4).Range.Text = sTmp                   ' Адрес подачи
        sTmp = .Cells(i, "E")
        If dicAddr.Exists(CStr(.Cells(i, "E"))) Then sTmp = dicAddr.Item(CStr(.Cells(i, "E")))
        WD.Tables(1).Rows(iNum).Cells(5).Range.Text = sTmp                   ' Адрес назначения
        WD.Tables(1).Rows(iNum).Cells(6).Range.Text = .Cells(i, "F").Text    ' Сумма
        WD.Tables(1).Rows(iNum).Cells(7).Range.Text = MSumProp(.Cells(i, "F"))  ' Сумма прописью
 
   Case "Шаблон_ненормированный_вечерние.docx"
        WD.Tables(1).Rows(iNum).Cells(1).Range.Text = iNum - 1               ' N
        WD.Tables(1).Rows(iNum).Cells(2).Range.Text = .Cells(i, "A").Text    ' Дата
        WD.Tables(1).Rows(iNum).Cells(3).Range.Text = .Cells(i, "B").Text    ' Время
        WD.Tables(1).Rows(iNum).Cells(5).Range.Text = .Cells(i, "F").Text    ' Сумма
        WD.Tables(1).Rows(iNum).Cells(6).Range.Text = MSumProp(.Cells(i, "F"))  ' Сумма прописью
End Select

Sub Ìàêðîñ2()
   Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
   Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
   Selection.EndKey Unit:=wdLine, Extend:=wdExtend
   Selection.MoveRight Unit:=wdWord, Count:=4, Extend:=wdExtend
   Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
   Selection.Copy
   Selection.EndKey Unit:=wdStory
   Selection.PasteAndFormat (wdPasteDefault)
End Sub