Что-то такое получилось. Вроде работает.
[vba]Код
Dim CntS, rn As Range
Dim rCopyRange As Range
Dim CnA
Sub Копировать()
If Selection.Count > 1 Then
Set rCopyRange = Selection.Cells
Else: Set rCopyRange = ActiveCell
End If
CntS = Selection.Rows.Count
End Sub
Sub Вставить()
On Error Resume Next
Dim rCell As Range, li As Long, le As Long, lCount As Long, iCol As Integer
Dim sA As String
Cntt = ActiveCell.Row
sA = ActiveCell.Address
ActiveSheet.Rows(Cntt).Resize(CntS).Insert
For iCol = 1 To rCopyRange.Columns.Count
li = 0: lCount = 0: le = iCol - 1
For Each rCell In rCopyRange.Columns(iCol).Cells
Do
rCell.Copy ActiveCell.Offset(li, le): lCount = lCount + 1
li = li + 1
Loop While lCount <= 0
Next rCell
Next iCol
End Sub
[/vba]