Option Explicit


Sub Macro1()
Dim Pos As Integer
Dim LC As Variant
Pos = 1

Application.ScreenUpdating = False

MainLoop:

LC = Cells(Pos, Columns.Count).End(xlToLeft).Column
Range(Pos + 1 & ":" & Pos + LC - 1).Insert Shift:=xlDown
Range(Cells(Pos, 2), Cells(Pos, LC)).Copy
Cells(Pos + 1, 1).PasteSpecial Transpose:=True
Range(Cells(Pos, 2), Cells(Pos, LC)).Clear
Pos = Pos + LC
If Cells(Pos, 1) <> "" Then GoTo MainLoop

Range("A2:A6").EntireRow.Delete
Range("A1").Value = "Sorted"
Columns(1).AutoFit

Application.ScreenUpdating = True

InsertBlankRows
Range("A2:A4").EntireRow.Delete
Range("A1").Select

End Sub
''/// For a set range of rows in a column
Sub InsertBlankRows()
'Step1:  Declare your variables.
    Dim MyRange As Range
    Dim iCounter As Long
    
Application.ScreenUpdating = False
    
'Step 2:  Define the target Range.
    Set MyRange = Range("A2:A50")
    
'Step 3:  Start reverse looping through the range.
    For iCounter = MyRange.Rows.Count To 1 Step -9
    
'Step 4: Insert two blank rows.
    MyRange.Rows(iCounter).EntireRow.Insert

'Step 5: Increment the counter down
    Next iCounter
    
Application.ScreenUpdating = True

End Sub