Макросами умеешь пользоваться?

Sub module1()

Dim i, j As Long
Dim r As Long
Dim st As String
r = 3
For i = 1 To 65535
If Cells(i, 1) = "" Then Exit For

If i = r Then
For j = 1 To 3
st = LTrim(Str(r + 1 + (j - 1))) + ":" + LTrim(Str(r + 1 + (j - 1)))
Rows(st).Select
Selection.Insert Shift:=xlDown
Cells(i + j, 1) = Cells(i - (3 - j), 1)
Next j

i = i + 3
r = i + 3
End If
Next i
End Sub

Тады вот так. Кол-во строк должно быть кратно трем, иначе последние 1 или 2 строки пропустит. Извините, долго думать, доделывать баги, не имею возможности, работа...))

Sub module1()

Dim i, j As Long
Dim r As Long
Dim st As String
n = 3
r = n
For i = 1 To 65535
If Cells(i, 1) = "" Then Exit For

If i = r Then
For k = 1 To 2
For j = 1 To n
st = LTrim(Str(r + 1 + (j - 1))) + ":" + LTrim(Str(r + 1 + (j - 1)))
Rows(st).Select
Selection.Insert Shift:=xlDown
Cells(i + j, 1) = Cells(i - (n - j), 1) '1 столбец
Cells(i + j, 2) = Cells(i - (n - j), 2) ' 2столбец
' если надо третий столбец, то Cells(i + j, 3) = Cells(i - (n - j), 3) и т. д.
Next j
Next k
i = i + 2 * n
r = i + n
End If
Next i
End Sub