Sub JoinRows()
Dim rng As Range, i, item, Dict, lCol As Long, lRow As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    Set rng = Application.InputBox("Выберите диапазон", Type:=8)
    For Each i In rng.Rows
        item = Application.Transpose(Application.Transpose(i.Value2))
        Dict.Add i.Row, item
    Next i
    lCol = 1
    lRow = Worksheets("то что должно получиться").Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each item In Dict.items()
        Worksheets("то что должно получиться").Cells(lRow, lCol).Resize(1, UBound(item)) = item
        lCol = UBound(item) + lCol
    Next item
End Sub

item = Application.Transpose(Application.Transpose(i.Value2))

Sh.Cells(Split(Sh.UsedRange.Address, "$")(4), 1).Offset(1).Resize(UBound(x), UBound(x, 2)).Value = x

Sub macroc2()
Application.ScreenUpdating = False
Dim i As Long
i = Sheets("лист1").Cells(Rows.Count, 4).End(xlUp).Row
Sheets("лист1").Range("D16:L" & i).Copy
i = Sheets("лист3").Cells(Rows.Count, 2).End(xlUp).Row + 1 'Îïðåäåëÿåì íèæ.Ñòðîêó
Sheets("лист3").Range("A" & i).Paste
Application.ScreenUpdating = True
End Sub

Sub Macro1()
    Range("A1:P1").Copy
    Cells(Application.Max(25, Cells(Rows.Count, 1).End(xlUp)(2).Row), 1).PasteSpecial xlPasteValues
End Sub

Function WithOutDgt$(s)
  Dim re: WithOutDgt = s
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^\d+"
  If re.test(s) Then WithOutDgt = re.Replace(s, "")
End Function

Function WithOutDgt$(s)
  Dim re: WithOutDgt = s
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^\d+"
  If re.test(s) Then WithOutDgt = re.Replace(s, "")
End Function