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