Difficult sort problem

This code will insert a blank row between each row.

Option Explicit

Sub Insert()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Dim rw As Variant
Dim rng As Range
Set rng = Range("A1:A" & lr)


For Each rw In rng.Rows 'For each row in your range...
    If rw.Row Mod 2 = 0 Then 'check to see if the row is even
        rw.Insert Shift:=xlDown 'if the row is even, insert a blank row above it
    End If
Next rw 'Keep going until you are out of rows


End Sub