Sub Import()
On Error Resume Next
Application.ScreenUpdating = False
Dim i As Long
    With ActiveDocument
    n = Val(InputBox("Сколько строк в таблице?"))
    If n = 0 Then Exit Sub
    k = n - 1 'корректировка количества строк
    r = n + 1 'корректировка количества строк
        With .Tables(3) 'обращаюсь к третьей таблице
        .Rows(2).Select 'выбираю позицию для добавления строк
        Selection.InsertRowsBelow k 'вставвка заданного количества строк
        .Rows(1).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble 'красявости
        .Rows(r).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble 'красявости
        rs = .Cell(2, 2).Range.Start 'начало дипазона для вставки
        re = .Cell(r, 6).Range.End 'конец дипазона для вставки
        ActiveDocument.Range(rs, re).Paste 'вставка из буфера в заданный диапазон
            For i = 2 To r
                If .Cell(i, 3).Range.Characters.Count = 3 Then 'определение строки для форматирования
                .Cell(i, 2).Range.Copy 'копирую в память содержимое ячейки
                .Rows(i).Range.Delete Unit:=wdCharacter, Count:=1 'очистка строки
                .Cell(i, 1).Merge MergeTo:=.Cell(i, 6) 'объединение ячеек
                .Rows(i).Range.Paste 'вставка ранее запомненного значения
                .Rows(i).Shading.BackgroundPatternColor = wdColorGray15 'красявости
                End If
            Next
        End With
    End With
Application.ScreenUpdating = True
End Sub

Sub ImportMetallTest()
Application.ScreenUpdating = False
Dim i As Integer
Dim S As String
    With ActiveDocument
    N = Val(InputBox("Сколько строк в таблице?"))
    If N = 0 Then Exit Sub
    k = N - 1
    R = N + 1
        With .Tables(3)
        .Rows(2).Select
        Selection.InsertRowsBelow k
        rs = .Cell(2, 2).Range.Start
        re = .Cell(R, 6).Range.End
        ActiveDocument.Range(rs, re).Paste
           For i = 2 To R
               If .Cell(i, 3).Range.Characters.Count = 3 Then
               S = .Cell(i, 2).Range
               .Rows(i).Range.Delete Unit:=wdCharacter, Count:=1
               .Cell(i, 1).Merge MergeTo:=.Cell(i, 6)
               .Rows(i).Range = S
               End If
           Next
       End With
    End With
Application.ScreenUpdating = True
End Sub

        For i = 2 To R
            If .Cell(i, 3).Range.Characters.Count = 3 Then
                S = .Cell(i, 2).Range.Text
                .Rows(i).Range.Delete Unit:=wdCharacter, Count:=1
                .Cell(i, 1).Merge MergeTo:=.Cell(i, 6)
                .Rows(i).Range = S
            End If
        Next

Sub ImportTest1()

Application.ScreenUpdating = False
Dim i As Integer
Dim S As String
With ActiveDocument
    N = Val(InputBox("Сколько строк в таблице?"))
    If N = 0 Then Exit Sub
    k = N - 1
    R = N + 1
    With .Tables(3)
        .Rows(2).Select
        Selection.InsertRowsBelow k
        rs = .Cell(2, 2).Range.Start
        re = .Cell(R, 6).Range.End
        ActiveDocument.Range(rs, re).Paste
        For i = 2 To R
            If .Cell(i, 3).Range.Characters.Count = 3 Then
                .Cell(i, 1).Merge MergeTo:=.Cell(i, 6)
                .Rows(i).Range = Left(.Rows(i).Range, Len(.Rows(i).Range) - 13)
            End If
        Next
    End With
End With
Application.ScreenUpdating = True

End Sub

Sub ImportTest2()

Application.ScreenUpdating = False
Dim i As Integer
Dim S As String
With ActiveDocument
'    N = Val(InputBox("Сколько строк в таблице?"))
    N = 2000
'    If N = 0 Then Exit Sub
    k = N - 1
    R = N + 1
    With .Tables(3)
        .Rows(2).Select
        Selection.InsertRowsBelow k
        rs = .Cell(2, 2).Range.Start
        re = .Cell(R, 6).Range.End
        ActiveDocument.Range(rs, re).Paste
 tm = Timer
        For i = 2 To R
            If .Cell(i, 3).Range.Characters.Count = 3 Then
                .Cell(i, 1).Merge MergeTo:=.Cell(i, 6)
                S = .Rows(i).Range
                S = Left(S, Len(S) - 13)
                .Rows(i).Range = S
            End If
       Next
    End With
End With
Application.ScreenUpdating = True

MsgBox Timer - tm, 64

End Sub

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

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