Sub ToWordTbl()

tm = Timer

    With Application
        .ScreenUpdating = False
    End With
On Error Resume Next

Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
Dim WrdTbl As Word.Table
Dim DocPath As String
Dim n As Integer, k As Integer, r As Integer, s As Integer, t As Integer
    With Worksheets("Лист1")
        n = .Range("A10")
        k = n - 1
        r = n + 1
        s = .Range("J10") + 9
        .Cells(11, 1).Resize(n, 5).Copy
    End With
    
    DocPath = ThisWorkbook.Path & "\"
    
    Set WrdApp = GetObject(, "Word.Application")
        If WrdApp Is Nothing Then Set WrdApp = CreateObject("Word.Application")
    Set WrdDoc = WrdApp.Documents.Open(DocPath & "Приемник.docx")
        If WrdDoc Is Nothing Then Set WrdDoc = WrdApp.Documents.Open(DocPath & "Приемник.docx")
    
    WrdApp.Visible = False
    
        If Dir(DocPath & "Приемник.docx") = "" Then
            MsgBox "Файл ""Приемник.docx"" отсутствует"
            WrdApp.Visible = True
            Exit Sub
        End If
      
    Set WrdTbl = WrdDoc.Tables(3)
    With WrdTbl

        If .Rows.Count > 2 Then
            MsgBox "Ошибка шаблона ""Приемник""."
            Application.CutCopyMode = False
            WrdApp.Visible = True
            Exit Sub
        End If
        
        .Rows(2).Select
            
        WrdApp.Selection.InsertRowsBelow k
        
        WrdDoc.Range(.Cell(2, 2).Range.Start, .Cell(r, 6).Range.End).PasteAndFormat (16)

        .Rows(1).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
        .Rows(r).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
               
        For i = 10 To s
            t = ThisWorkbook.Worksheets("Лист1").Cells(i + 1, 10) + 1
            
            .Cell(t, 2).Range.Copy
            WrdDoc.Range(.Cell(t, 1).Range.Start, .Cell(t, 6).Range.End).Delete
            .Cell(t, 1).Merge MergeTo:=WrdApp.ActiveDocument.Tables(3).Cell(t, 6)
            .Cell(t, 1).Range.PasteAndFormat (16)
        Next

    End With

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

WrdApp.Visible = True

MsgBox Timer - tm, 64

End Sub

Set WrdApp = GetObject(, "Word.Application")

On Error Resume Next

ScreenUpdating

On Error Resume Next