Sub test()
a = Range("a1:a65536")
b = Application.Transpose(a)
Debug.Print UBound(b)
a = Range("a1:a65537")
b = Application.Transpose(a)
Debug.Print UBound(b)
End Sub

Sub test()
Dim arr_out(), Arr_OT_DO(), i&, iStep&
    arr_out = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    arr_out = TransposeArray_2to1(arr_out)
    iStep = 100000  ' здесь нужное число строк или activesheet.Rows.count
Application.ScreenUpdating = False
    Dim Start!:           Start = Timer
    For i = LBound(arr_out) To UBound(arr_out) Step iStep
        Arr_OT_DO = splitArr(arr_out, i, i + iStep - 1)
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Cells(1, 1).Resize(UBound(Arr_OT_DO) + 1, 1).Value = TransposeArray_1to2(Arr_OT_DO)
            .Cells(UBound(Arr_OT_DO) + 1, 1).Select
        End With
    Next
    Sheet1.Activate
    Debug.Print "Затрачено: " & Format(Timer - Start, "#0.00") & " сек."
Application.ScreenUpdating = True
End Sub

Private Function splitArr(ByVal Massiv As Variant, ByVal OT_&, ByVal DO_&)
'режет одномерный массив
Dim i&, TmpArr() As Variant
If UBound(Massiv) < DO_ Then DO_ = UBound(Massiv)
ReDim TmpArr(0 To DO_ - OT_)
    For i = OT_ To DO_ Step 1
        TmpArr(i - OT_) = Massiv(i)
    Next i
    splitArr = TmpArr
End Function

Function TransposeArray_2to1(ByRef SourceArray() As Variant) As Variant
'Транспонирует из двумерного в одномерный
    Dim OT_&: OT_ = LBound(SourceArray, 1)
    Dim DO_&: DO_ = UBound(SourceArray, 1)
    Dim TempArray As Variant, i&
    ReDim TempArray(OT_ To DO_)
    For i = OT_ To DO_
        TempArray(i) = SourceArray(i, 1)
    Next i
    TransposeArray_2to1 = TempArray
End Function

Function TransposeArray_1to2(ByRef SourceArray() As Variant) As Variant
'Транспонирует из одномерного в двумерный
    Dim OT_&: OT_ = LBound(SourceArray)
    Dim DO_&: DO_ = UBound(SourceArray)
    Dim TempArray As Variant, i&
    ReDim TempArray(OT_ To DO_, 1 To 1)
    For i = OT_ To DO_
        TempArray(i, 1) = SourceArray(i)
    Next i
    TransposeArray_1to2 = TempArray
End Function

Sub d()
Dim arr, arr2, i#, shN!, ii&, n#, n2&

n = 4546325

'Create arr:
ReDim arr(1 To n)
For i = 1 To n: arr(i) = i: Next
i = 1

'start loop
Do While i <= n
    n2 = IIf(n - i < Rows.Count - 2, n - i + 1, Rows.Count - 1)
    arr2 = GetPartArr(arr, i, i + n2 - 1)
    Sheets.Add after:=Sheets(Sheets.Count)
    [a2].Resize(UBound(arr2)) = arr2
    i = i + n2
Loop
End Sub
Function GetPartArr(arr, iStart, iFin)
ReDim arr2(1 To iFin - iStart + 1, 1 To 1)
    For i = 1 To UBound(arr2)
        arr2(i, 1) = arr(iStart + i - 1)
    Next
GetPartArr = arr2
End Function

Массив создан за 10,76 сек.
Данные выгружены за 22,19 сек.

ReDim arr_out(1 To komb)

        Erase arr_v '÷èñòèì îïåðàòèâêó
        Erase arr_v 'чистим оперативку
        Erase arr_sh
'SLAVIK'
        i = 1
        n = UBound(arr_out)
                Do While i <= n
                    n2 = IIf(n - i < Rows.Count - 2, n - i + 1, Rows.Count - 1)
                    arr2 = GetPartArr(arr_out, i, i + n2 - 1)
                    Sheets.Add after:=Sheets(Sheets.Count)
                    [a2].Resize(UBound(arr2)) = arr2
                    Erase arr2 'еще раз чистим
                    i = i + n2
                Loop

GetPartArr = arr2