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

Dim CntS as Integer
Dim rn As Range
Dim rd As Range

Sub Копирование() 'выбираем диапазон-источник
   Set rn = Selection ' Диапазон-источник
CntS = Selection.Rows.Count 'кол-во строк
UserForm1.Show 'диалог для выбора места вставки
End Sub

Sub Вставка() ' после выбора диапазона-приёмника
Application.CutCopyMode = False
ActiveCell.Resize(CntS).EntireRow.Insert 'вставляет нужное кол. строк
   Set rd = Selection                 'диапазон-приёмник
rn.Copy Destination:=rd 'Копирует диапазон-источник в диапазон-приёмник
End Sub