Sub johnmplBigStackSHimpfGlifiedEdited()
Rem 0) 'Check time for do it
Dim t As Single: t = Timer
Rem 1) 'Worksheets info, Input Data
Dim WB As Workbook: Set WB = ThisWorkbook
Dim wsData As Worksheet: Set wsData = WB.Worksheets("Hoja1SmallTestie")
Dim srT As Long, sr1 As Long
Let sr1 = wsData.Cells.Find("*", wsData.Cells(1, 1), xlValues, xlPart, xlByRows, xlNext).Row
Rem 2) 'Make Stack Array ( 1 D array of " D Array )
Dim arrIn(), StackChops()
Dim rngNo As Long
Do While srT <> sr1
If srT = 0 Then Let srT = sr1
Let rngNo = rngNo + 1
With wsData.Cells(srT, wsData.Cells.Find("*", wsData.Cells(srT, 1), xlValues, xlPart, xlByRows, xlNext).Column).CurrentRegion
Let arrIn() = .Offset(2).Resize(.Rows.Count - 2).Value2
End With
ReDim Preserve StackChops(1 To rngNo)
Let StackChops(rngNo) = arrIn()
Let srT = srT + UBound(StackChops(rngNo), 1) + 2
Let srT = wsData.Cells.Find("*", wsData.Cells(srT, 1), xlValues, xlPart, xlByRows, xlNext).Row
Loop
Rem 3) ' Paste out stacks to tempory Sheet: if Shheet does not exist first make it
If Not Evaluate("=ISREF('Temp'!A1)") Then
WB.Worksheets.Add(After:=wsData).Name = "Temp"
Else
ThisWorkbook.Worksheets("Temp").Move After:=wsData
Worksheets("Temp").Activate
Worksheets("Temp").Cells.Clear
End If
Dim j As Long, y As Long: Let y = 1
For j = 1 To UBound(StackChops())
Worksheets("Temp").Range("A" & y).Resize(UBound(StackChops(j), 1), UBound(StackChops(j), 2)).Value = StackChops(j)
Let y = y + UBound(StackChops(j), 1)
Next j
Rem 4) ' Produce Final Output Array
Dim arrOut(): Let arrOut() = Worksheets("Temp").UsedRange.Value
MsgBox "Terminated in " & Format(Timer - t, "0.000 seg")
' Rem 5) 'Demonstrate Output Array
' Dim strMsgBox As String
' For j = 1 To UBound(StackChops())
' For y = 1 To UBound(StackChops(j), 1)
' Let strMsgBox = strMsgBox + Join(Application.Index(StackChops(j), y, 0), ",") & vbLf
' Next y
' MsgBox Prompt:="Stack Array element " & j & " looks like this " & vbLf & strMsgBox & ""
' Let strMsgBox = ""
' Next j
' Let strMsgBox = ""
'
' For y = 1 To UBound(arrOut(), 1)
' Let strMsgBox = strMsgBox + Join(Application.Index(arrOut(), y, 0), ",") & vbLf
' Next y
' MsgBox Prompt:="Output Array looks like this " & vbLf & strMsgBox & ""
End Sub
