Limitation for Transpose Function - excel

Question

I am trying to find a workaround as transpose will not fit my data size, which is giving me an error. What do I added in right before the end of the loop -before the Next- to paste the data on a new sheet? Will this slow down the macro it the output is 100,000 lines
After reviewing the code I realized that if I make the range to a certain number it works and +1 row after that it errors out. Turns out transpose is to blame.
For Q = 1 To Data + 1
n = n + 1
ReDim Preserve var(1 To 3, 1 To n)
var(1, n) =
For R = 2 To 6
var(r, n) =
Next R
var(1, n) =
var(2, n) =
Next Q
Next_Loop:
Next P
With this workbook.sheet1
If Q>= 2 Then
.Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(var)
End If
The result should be instead of pasting all the data at the end, it pastes the data after each iteration (unless it slows down the macro). Next iteration would be below the previous line of data. etc.
thank you for any insight

Answer 1

Here is an option for you to try.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
If you want one long column cut into a few long rows, then use this.
Sub LongColumnToAFewRows()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results2"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step Columns.Count
wsF.Cells(R, 1).Resize(Columns.Count).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues, Transpose:=True
j = j + 1
Next R
End Sub
One more for consideration.
Sub testing()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim ptrSource As Long
Dim ptrDest As Long
Dim colDest As Long
Set wsDest = Sheets.Add
wsDest.Name = "Results"
Set wsSource = Worksheets("Sheet1")
colDest = 1
ptrSource = 1
ptrDest = 1
Do While Len(wsSource.Cells(ptrSource, 1)) > 0
wsDest.Cells(ptrDest, colDest) = wsSource.Cells(ptrSource, 1)
If colDest = Columns.Count Then
colDest = 0
ptrDest = ptrDest + 1
End If
ptrSource = ptrSource + 1
colDest = colDest + 1
Loop
Set wsDest = Nothing
Set wsSource = Nothing
End Sub