.
Here is one way to accomplish the goal :
Code:
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:A4").EntireRow.Delete
Range("A1").Value = "Sorted"
Columns(1).AutoFit
Application.ScreenUpdating = True
InsertBlankRows
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 -4
'Step 4: Insert two blank rows.
MyRange.Rows(iCounter).EntireRow.Insert
'Step 5: Increment the counter down
Next iCounter
Application.ScreenUpdating = True
End Sub