Sub Выстота_строк()
    Dim a As Variant
    Dim y As Long
    y = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    ReDim a(1 To y, 1 To 1)
    For y = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
        a(y, 1) = Rows(y).Height
    Next
    Cells(1, 1).Resize(UBound(a, 1)) = a
End Sub

Sub Main()
    Dim r As Range
    Set r = ActiveSheet.UsedRange.Columns(1)
        
    Dim arr As Variant
    arr = r
    
    SortArray arr, 1
End Sub
'
Sub SortArray(arr As Variant, iColumn As Integer)    'Сортировка расчёской
    Dim d As Long
    Dim bNextTurnExit As Boolean: bNextTurnExit = False
    
    Dim i As Long
    Dim j As Long
    Dim t As Variant
    Dim x As Integer
    
'    Dim yOut As Byte: yOut = 1
'    Cells(yOut, 3).Value = Join(arr): yOut = yOut + 1
    
    Dim dh As Double
    dh = UBound(arr, 1) - LBound(arr, 1)
    If dh < 2 Then Exit Sub
    Do
        dh = dh / 1.247
        d = Round(dh, 0)
        
        If bNextTurnExit Then d = 1
        i = LBound(arr, 1)
        Do
            j = i + d
            If j > UBound(arr, 1) Then Exit Do
            If arr(i, iColumn) > arr(j, iColumn) Then
                
                For x = LBound(arr, 2) To UBound(arr, 2)
                    t = arr(j, x)
                    arr(j, x) = arr(i, x)
                    arr(i, x) = t
                Next
                
                Rows(j).Copy Rows(100000)
                Rows(i).Copy Rows(j)
                Rows(100000).Copy Rows(i)
                
'                Cells(yOut, 3).Value = Join(arr): yOut = yOut + 1
            End If
'            Cells(yOut, 3).Value = Join(arr): yOut = yOut + 1
            i = i + 1
            DoEvents
        Loop
        
        If bNextTurnExit Then Exit Do
        If d <= 1 Then bNextTurnExit = True
    Loop
    
End Sub