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