WrdDoc.Range(.Cell(2, 2).Range.Start, .Cell(r, 6).Range.End)

Sub ToWordTbl()

tm = Timer

Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
Dim WrdTbl As Word.Table
Dim DocPath As String, d As String
Dim n As Integer, s As Integer
Dim str() As Variant
        
        n = Worksheets("Лист1").Range("A10")
        If n = 0 Then
            MsgBox "Таблица пустая"
        Exit Sub
        End If
    
    With Worksheets("Лист1")
        s = .Range("J10") + 12
        .Cells(11, 1).Resize(n, 5).Copy
        str = .Range(Cells(11, 10), Cells(s, 10)).Value
    End With
    
    DocPath = ThisWorkbook.Path & "\"
    
    On Error Resume Next
    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")
    On Error GoTo 0

    WrdApp.Visible = False
    
        If Dir(DocPath & "Приемник.docx") = "" Then
            MsgBox "Файл ""Приемник.docx"" отсутствует"
            Application.CutCopyMode = False
            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
            On Error Resume Next
            WrdApp.Selection.InsertRowsBelow n - 1
            On Error GoTo 0
        
        WrdDoc.Range(.Cell(2, 2).Range.Start, .Cell(n + 1, 6).Range.End).PasteAndFormat (16)

        .Rows(1).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
        .Rows(n + 1).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
               
        For i = 1 To UBound(str) - 2
            d = .Cell(str(i, 1) + 1, 2).Range
            .Cell(str(i, 1) + 1, 1).Merge MergeTo:=WrdApp.ActiveDocument.Tables(3).Cell(str(i, 1) + 1, 6)
            d = Left(d, Len(d) - 2)
            .Cell(str(i, 1) + 1, 1).Range = d
        Next

    End With

    With Application
        .CutCopyMode = False
    End With

    WrdApp.Visible = True

MsgBox Timer - tm, 64


End Sub

Dim tbl As Variant

tbl = .Cells(11, 1).Resize(n, 5).Text

WrdDoc.Range(.Cell(2, 2).Range.Start, .Cell(n + 1, 6).Range.End) = tbl