Split 2d array into multiple equal 2d arrays

[Doc.AElstein]

Alan, for your CL function, a variant:
CL = Split(Cells(1, lclm).Address, "$")(1)
... it will return an error when a column number is given which is greater than the number of columns in that version of Excel.

Thanks, I have seen that. I did a few test on a few ways a while back,
https://excelfox.com/forum/showthread.p ... 1#post7214
there was not a lot in it, but the one I gave was marginally the fastest. The address one is a good idea if you want to avoid the messing about with the transpose, so perhaps the best to use here. I forgot about it at the time. Its a neater way to overcome having to use the transpose
It's only used once anyway , so the address one is really the better to use here
This would be another way then to do without the Transpose, the best way I think probably

Code: Select all

Sub BitNeater()
Rem 1 p45 array
Dim Ub As Long: Let Ub = 25    'upper bound of the array
Dim arrIn() As String
ReDim arrIn(1 To Ub, 1 To 1)    'a single column 2d array.
Dim Eye As Long
    For Eye = 1 To Ub
     Let arrIn(Eye, 1) = "Name " & Eye
    Next Eye
Const nRows As Long = 7 '  7 "rows"

Rem 3 Single Output array in one go
Dim arrOut() As Variant ' needs to be  Variant  as that is the type of the element buckets chicked back ba  Index
 'Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(COLUMN(A:D)-1)*7"), Array(1))
 'Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(COLUMN(A:" & CL(4) & ")-1)*7"), Array(1))
' Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(COLUMN(A:" & CL(Int((Ub - 1) / nRows) + 1) & ")-1)*7"), Array(1))
 Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(COLUMN(A:" & Split(Cells(1, Int((Ub - 1) / nRows) + 1).Address, "$")(1) & ")-1)*" & nRows & ""), Array(1))

Rem 4 ' arbritrary output range
 Let Range("E1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()

End Sub

[YasserKhalil]

The same REF error is still there. The issue is OK except for that point only.

[Doc.AElstein]

I don’t think there is any simple “one liner” type way to overcome that before pasting out, because
_ you cant adjust things ( element contents I mean here ) , in part of an array without looping
_ we can only paste out a single rectangular area.

We can possibly do a fairly efficient range evaluate thing to get rid of those errors, after pasting out

We know how to do this sort of thing:
Take some basic formulas,
Example like
=IF(ISERROR(H7),"",H7)
Or
=IFERROR(H6,"")
Then turn them into the Evaluate range non looping one liner type thing…

Using the same test range as before:

Code: Select all

Sub ErrorWeg1() '
Rem 1 p45 array
Dim Ub As Long: Let Ub = 25    'upper bound of the array
Dim arrIn() As String
ReDim arrIn(1 To Ub, 1 To 1)    'a single column 2d array.
Dim Eye As Long
    For Eye = 1 To Ub
     Let arrIn(Eye, 1) = "Name " & Eye
    Next Eye
Const nRows As Long = 7 '  7 "rows"
' _______________________________________________________________________________-



 Let Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(COLUMN(A:" & Split(Cells(1, Int((Ub - 1) / nRows) + 1).Address, "$")(1) & ")-1)*" & nRows & ""), Array(1))
 Let Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Evaluate("=IF(ISERROR(" & Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Address & "),""""," & Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Address & ")")
End Sub

Sub ErrorWeg2() '
Rem 1 p45 array
Dim Ub As Long: Let Ub = 25    'upper bound of the array
Dim arrIn() As String
ReDim arrIn(1 To Ub, 1 To 1)    'a single column 2d array.
Dim Eye As Long
    For Eye = 1 To Ub
     Let arrIn(Eye, 1) = "Name " & Eye
    Next Eye
Const nRows As Long = 7 '  7 "rows"
' _______________________________________________________________________________-


    With Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1)
     Let .Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(COLUMN(A:" & Split(Cells(1, Int((Ub - 1) / nRows) + 1).Address, "$")(1) & ")-1)*" & nRows & ""), Array(1))
     Let .Value = Evaluate("=IF(ISERROR(" & .Address & "),""""," & .Address & ")")
    End With
End Sub

Sub ErrorWeg3() '
Rem 1 p45 array
Dim Ub As Long: Let Ub = 25    'upper bound of the array
Dim arrIn() As String
ReDim arrIn(1 To Ub, 1 To 1)    'a single column 2d array.
Dim Eye As Long
    For Eye = 1 To Ub
     Let arrIn(Eye, 1) = "Name " & Eye
    Next Eye
Const nRows As Long = 7 '  7 "rows"
' _______________________________________________________________________________-



 Let Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(COLUMN(A:" & Split(Cells(1, Int((Ub - 1) / nRows) + 1).Address, "$")(1) & ")-1)*" & nRows & ""), Array(1))
 Let Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Evaluate("=IFERROR(" & Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Address & ","""")")
End Sub

Sub ErrorWeg4() '
Rem 1 p45 array
Dim Ub As Long: Let Ub = 25    'upper bound of the array
Dim arrIn() As String
ReDim arrIn(1 To Ub, 1 To 1)    'a single column 2d array.
Dim Eye As Long
    For Eye = 1 To Ub
     Let arrIn(Eye, 1) = "Name " & Eye
    Next Eye
Const nRows As Long = 7 '  7 "rows"
' _______________________________________________________________________________-


    With Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1)
     Let .Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(COLUMN(A:" & Split(Cells(1, Int((Ub - 1) / nRows) + 1).Address, "$")(1) & ")-1)*" & nRows & ""), Array(1))
     Let .Value = Evaluate("=IFERROR(" & .Address & ","""")")
    End With
End Sub

[YasserKhalil]

Amazing. Thank you very much. You are incredible
Best Regards

[Doc.AElstein]

Hello…

I think while this is still fresh in my mind I will check the case of an array with more than one column, as I am sure the question will come up later.. and .. a stitch in time saves nine… :)
( and as p45 reminded me of that address way to get the column Letter, I don’t need to go crazy trying to do multiple transposing, so that saves me a lot of headaches and makes things a lot easier.…)

I’ll just give the pretty results in the post.
The full workings are in the second worksheet of the attached file, both in the worksheet spreadsheet and in the worksheet code module.

ItsAllSoBeautiful.xls

_.__________________________________

So, if you want to Split a 2dArray arrIn() Into Multiple Equal 2d Arrays, but have all those output arrays put into a single array, arrOut() , then this should do it

Code: Select all

 Sub Split2dArrayIntoMultipleEqual2dArrays()
' test range
Dim arrIn() As Variant: Let arrIn() = Me.Range("B2:D6").Value2

' _______________________________________

Dim Ub As Long, nRows As Long, ClmCnt As Long
 Let Ub = 5                          ' the row number of the input range
 Let nRows = 2                       ' the row number you want to slice the range into
 Let ClmCnt = UBound(arrIn(), 2) ' 3 ' The column number in the input range
Dim arrOut() As Variant
 Let arrOut() = Application.Index(arrIn(), Evaluate("=((INT((COLUMN(A:" & Split(Cells(1, (((Int((Ub - 1) / nRows)) + 1)) * ClmCnt).Address, "$")(1) & ")-1)/" & ClmCnt & "))*" & nRows & ")+ROW(1:" & nRows & ")"), Evaluate("=If({1},MOD(COLUMN(A:" & Split(Cells(1, (((Int((Ub - 1) / nRows)) + 1)) * ClmCnt).Address, "$")(1) & ")-1," & ClmCnt & ")+1)"))
 ' demo output, top left is P2
    With Range("P2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
     Let .Value = arrOut()
     Let .Value = Evaluate("=IF(ISERROR(" & .Address & "),""""," & .Address & ")")
    End With
End Sub

Here next is a slight variation of the above for doing something similar. In this case you have a spreadsheet range, and you want to do a similar splitting.

Code: Select all

 Sub EvalSpreadsheetIndex()
Dim Ub As Long, nRows As Long, ClmCnt As Long
 Let Ub = 5     ' the row number of the input range
 Let nRows = 2  ' the row number you want to slice the range into
 Let ClmCnt = 3 ' The column number in the input range
    With Me.Range("P2").Resize(nRows, ((Int((Ub - 1) / nRows)) + 1) * ClmCnt)
     Let .Value = Evaluate("=If({1},INDEX(B2:D6,N(If(1,((INT((COLUMN(A:" & Split(Cells(1, (((Int((Ub - 1) / nRows)) + 1)) * ClmCnt).Address, "$")(1) & ")-1)/" & ClmCnt & "))*" & nRows & ")+ROW(1:" & nRows & "))),N(If(1,MOD(COLUMN(A:" & Split(Cells(1, (((Int((Ub - 1) / nRows)) + 1)) * ClmCnt).Address, "$")(1) & ")-1," & ClmCnt & ")+1))))")
     Let .Value = Evaluate("=IF(ISERROR(" & .Address & "),""""," & .Address & ")")
    End With
End Sub 

Both use a typical test range to demo what’s going on.
This is your input:

Range B2-D6.JPG

This is the output

Output Top Left P2.JPG

I have not tested thoroughly, yet. I just wanted to put the stuff somewhere useful to get it from later, and maybe someone can use it in the meantime - The thread title fits nicely so me or someone should be able to find it later



I think these sort of things are doing something like a spreadsheet array formula, and maybe could be an alternative for a “big” range.
For a small range you might as well just do a formula, and for a much larger range, other VBA ways are probably better.
Maybe these sort of things are a nice alternative for a middle size requirement, maybe

Alan