Split 2d array into multiple equal 2d arrays

[YasserKhalil]

Hello everyone

I have a 2d array and I would like to split it into equal 2d arrays but to make the number of output arrays flexible (I mean I need sometimes 3 2d arrays .. sometimes 4 .. sometimes 5) so I need an approach that makes that more flexible
Or away from the number of rows [UBound(a,1)], How can I specify a specific number of rows say (20 rows) and the main 2d array to be split according to the whole number of the main array

Example: Say I have a 2d array named "arr" and it has about 70 rows. Then I decided through a constant named "nRows" to be equal to 25
so I need an output of three 2d arrays: the first will have 25 rows, the second will have 25 rows and the third will have 20 rows (or even 25 rows) but the last five rows will be empty of course

To make the issue clearer: Put the header "Names" in cell A1 then in A2 put the value "Name1" and drag it to A26 so "Name25" will be in A26
The constant nRows = 9
so the names from Name1 to Name9 would be an array
the names from Name10 to Name18 would be another array
the remaining names from Name19 to Name25 would be in an array

The output will not be in adjacent cells say the output arrays would be in cells E1 and H1 and J1

When I think of the issue, it would be confusing a little so I will make the number of outputs as constant too say nArrays = 3

[HansV]

Why not simply copy parts of the range in a loop?

[YasserKhalil]

Because the original 2d array is part of a code not directly in a worksheet.

[HansV]

You could fill a range with the array...

[YasserKhalil]

Does that mean to create a temp worksheet then to put the main output array then dealing with it?

[HansV]

Yes, indeed.

[YasserKhalil]

Is it possible doing that using arrays as the process will be executed many times (about 20 times) and as you know writing to the worksheet many times would slow down the performance of the code?

[HansV]

Let's see if DocAElstein has a suggestion, he seems to like such stuff.

[YasserKhalil]

This is my try

Code: Select all

Sub Test()
    Const nRows As Long = 9
    Const sCells As String = "E1,H1,J1"
    Dim a, t, r As Range, n As Long, i As Long, m As Long, ii As Long
    n = UBound(Split(sCells, ",")) + 1
    a = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = 1 To n
        Set r = Range(Split(sCells, ",")(i - 1))
        Columns(r.Column).ClearContents
        t = Slice(a, m, m + nRows - 1)
        m = m + nRows
        If i = n Then
            For ii = UBound(t) To LBound(t) Step -1
                If IsError(t(ii)) Then t(ii) = Empty Else Exit For
            Next ii
        End If
        r.Resize(UBound(t)).Value = Application.Transpose(t)
        Set r = Nothing
    Next i
End Sub

Function Slice(ByVal arr, ByVal f, ByVal t)
    Slice = Application.Index(arr, Evaluate("Transpose(Row(" & f + 1 & ":" & t + 1 & "))"))
End Function

[p45cal]

I did some testing a few years ago while experimenting with slicing and dicing arrays like you're doing and discovered it was much slower than plain looping.
Here's a couple of ways to split in-memory arrays:

Code: Select all

Sub blah3()
'Setup a sample array to split since you say the original 2d array is part of a code not directly in a worksheet:
Ub = 25    'upper bound of the array
ReDim arr(1 To Ub, 1 To 1)    'a single column 2d array.
For i = 1 To Ub
  arr(i, 1) = "Name " & i
Next i

'Now to do something with it:
Const nRows As Long = 7
Set arrColl = New Collection 'where the subarrays will be held

For i = 1 To UBound(arr)
  ReDim subArr(1 To nRows, 1 To 1)
  For j = 1 To nRows
    If i > UBound(arr) Then Exit For
    subArr(j, 1) = arr(i, 1)
    i = i + 1
  Next j
  i = i - 1
  arrColl.Add subArr
Next i
'Now you have all your subArrays in the arrColl collection to do something with, eg.:
'gain access to a value:
Debug.Print arrColl(4)(1, 1)

'print to sheet:
Set Destn = Range("E1")
For Each littleArray In arrColl
  Destn.Resize(nRows).Value = littleArray
  Set Destn = Destn.Offset(, 2)
Next littleArray
'A collection is read only so you can't write to it.

End Sub

and

Code: Select all

Sub blah4() 'load into an array
'Setup a sample array to split since you say the original 2d array is part of a code not directly in a worksheet:
Ub = 25    'upper bound of the array
ReDim arr(1 To Ub, 1 To 1)    'a single column 2d array.
For i = 1 To Ub
  arr(i, 1) = "Name " & i
Next i


'Now to do something with it:
Const nRows As Long = 7
ReDim NewArr(1 To 1)
arrCount = 0 'running count of subArrays
For i = 1 To UBound(arr)    ' Step nRows
  ReDim subArr(1 To nRows, 1 To 1)
  For j = 1 To nRows
    If i > UBound(arr) Then Exit For
    subArr(j, 1) = arr(i, 1)
    i = i + 1
  Next j
  i = i - 1
  arrCount = arrCount + 1
  ReDim Preserve NewArr(1 To arrCount)
  NewArr(arrCount) = subArr
Next i

'Now you have all your subArrays in the NewArray array you need to do something with them, eg.:
'Since this is an array you can write as well read to/from it:
NewArr(3)(2, 1) = "OOPS!"
Debug.Print NewArr(4)(1, 1)
'print to sheet:
Set Destn = Range("E1")
For Each littleArray In NewArr
  Destn.Resize(nRows).Value = littleArray
  Set Destn = Destn.Offset(, 2)
Next littleArray
End Sub

See commentsin the code.
It currently handles 2d arrays of 1 column but it's easy to adapt for any number of columns.
You could also use a dictionary to hold the arrays which I suspect would be even faster and a bit more flexible.

[Doc.AElstein]

Let's see if DocAElstein has a suggestion,...

How does the saying go…… I missed the distant call of my name in vain … :)
_.____________________________

This is my try..

without a sample worksheet, I can’t easily guess what it is you are trying to do there. Never mind…
_.__________________________
I will do a comparison way to what p45 did.
He has a 25 “row” array, ( Ub = 25 )
and he splits it into arrays of 7 “rows”, ( nRows = 7 )
So I copy that bit, then….

If we want to use the arrOut()=Index(arrIn() Rws(), Clms()) idea, then we need to do a bit of maths to get ( dynamically) the row indices of like
1
2
3
4
5
6
7


8
9
10
11
12
13
14

15
16
17
18
19
20
21

22
23
24
25

Based on our usual way of getting those “vertical” row indices, something like
Evaluate("=Row(1:7)")
, then the main thing we need to do is get (dynamically) the sets of numbers,
1:7
8:14
15:21
22:25
My maths is not the best, but maybe something like this…

Code: Select all

'  https://eileenslounge.com/viewtopic.php?p=290078#p290078
Sub SplitSplitHooRay()
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

'Now to do something with it, split it into sub arrays of 7 "rows"
Const nRows As Long = 7
Rem 2 maths stuff
Dim N As Long: Let N = Int((Ub - 1) / nRows) + 1 ' number of sub array

Rem 3 Loop to make array of arrays
Dim arrARays() As Variant ' for an array of arrays
ReDim arrARays(1 To N)
Dim Cnt As Long
    For Cnt = 1 To N
    Dim TopInd As Long, BtmInd As Long ' the first and last "row" indicie for th sub arrays
     Let BtmInd = ((Cnt - 1) * nRows) + 1 '  gives us   1   8  15  22
     Let TopInd = BtmInd + (nRows - 1)
        If TopInd > Ub Then Let TopInd = Ub '  gives  7  14  21  25
    ' 3a) Sub Array
    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(" & BtmInd & ":" & TopInd & ")"), Array(1))
    '3b) put sub array in array of array
     Let arrARays(Cnt) = arrOut()
    Next Cnt

Rem 4 ' arbritrary output range ( to match p45's ) 'print to sheet
Dim Destn As Range: Set Destn = ActiveSheet.Range("E1")
Dim littleArray As Variant
    For Each littleArray In arrARays()
     Let Destn.Resize(UBound(littleArray, 1), 1).Value = littleArray
     Set Destn = Destn.Offset(, 2)
    Next littleArray
End Sub

It gives the same results as the Sub blah3() from p45


The main part is Rem 2 and Rem 3 ( the rest is just making it a working example to compare with that from p45 )
The input array is arrIn() and that input array is split into 4 sub arrays, the first 3 sub arrays have 7 rows, and the last sub array has 4 rows
Those 4 sub arrays are put in an array of arrays , arrARays()


( if your original array had 2 columns then change Array(1) to Array(1, 2)
if your original array had 3 columns then change Array(1) to Array(1, 2, 3)
_...... etc…. )

_.__________________________________________________________________________________________

To demonstrate this…..

Example: Say I have a 2d array named "arr" and it has about 70 rows. Then I decided through a constant named "nRows" to be equal to 25
so I need an output of three 2d arrays: the first will have 25 rows, the second will have 25 rows and the third will have 20 rows....

Same macro but with Ub=70 , nRows=25

Code: Select all

Sub SplitSplitHooRay70_25()
Rem 1 p45 array
Dim Ub As Long: Let Ub = 70    '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

'Now to do something with it, 
Const nRows As Long = 25
Rem 2 maths stuff
Dim N As Long: Let N = Int((Ub - 1) / nRows) + 1 ' number of sub array

Rem 3 Loop to make array of arrays
Dim arrARays() As Variant ' for an array of arrays
ReDim arrARays(1 To N)
Dim Cnt As Long
    For Cnt = 1 To N
    Dim TopInd As Long, BtmInd As Long ' the first and last "row" indicie for th sub arrays
     Let BtmInd = ((Cnt - 1) * nRows) + 1 ' 
     Let TopInd = BtmInd + (nRows - 1)
        If TopInd > Ub Then Let TopInd = Ub '  
    ' 3a) Sub Array
    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(" & BtmInd & ":" & TopInd & ")"), Array(1))
    '3b) put sub array in array of array
     Let arrARays(Cnt) = arrOut()
    Next Cnt

Rem 4 ' arbritrary output range ( to match p45's ) 'print to sheet
Dim Destn As Range: Set Destn = ActiveSheet.Range("E1")
Dim littleArray As Variant
    For Each littleArray In arrARays()
     Let Destn.Resize(UBound(littleArray, 1), 1).Value = littleArray
     Set Destn = Destn.Offset(, 2)
    Next littleArray
End Sub

Output:

SplitArray70intoArrays_25_25_20.JPG

Alan

[p45cal]

Interested in confirming my years-ago research into timings, here are some results (printing routines excluded),seconds on the left:
161.335 Test ub=50000
91.70313 SplitHooray ub=50000
0.046875 blah3 ub=50000 (uses the Collection object)
0.0234375 blah4 ub=50000 (uses a plain array)

SplitHooray timings go up out of proportion to the Ub used:
0.03125 SplitHooray ub=1000
0.765625 SplitHooray ub=5000
2.8125 SplitHooray ub=10000
13.82813 SplitHooray ub=20000
20.71094 SplitHooray ub=25000
91.70313 SplitHooray ub=50000

as do YasserKhalil's Test macro:
0.0620 Test ub=1000
1.220947 Test ub=5000
4.987915 Test ub=10000
21.90308 Test ub=20000
36.35608 Test ub=25000
161.335 Test ub=50000

[YasserKhalil]

Amazing p45cal and Mr. Alan
Thank you very much for these awesome contributions.

[Doc.AElstein]

Interesting timing results. I don’t have the real life practical experience myself with these thing. The compact non looping idea coding that I like I picked up from others like snb and Rick Rothstein. I notice that in recent years Rick and a few others have commented that some of the nice compact looking one liners sometimes have disappointing timing results compared to simple looping equivalents. I have also heard that collection/ dictionary things can be very good because they somehow use some direct efficient way of computer storage compared to having the same data in a VBA array. (The “ Range Evaluate” one liners can often be a bit better than looping, but sometimes these index things and similar Evalute “slicing and dicing“ ideas I have heard said to be disappointing).
( SplitHooRay has a few extra unnecessary steps, which I often put in when sharing to try to make it easier to understand what’s going on. It could be a bit more simplified, but I doubt it would improve it's time performance greatly, if at all: If you can live with the last array not being truncated , then this would be a slightly simplified form

Code: Select all

Sub SplitHooRayS()
Rem 1 p45 array
Dim Ub As Long: Let Ub = 70    '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

'Now to do something with it, split it into sub arrays of 7 "rows"
Const nRows As Long = 25
Rem 2 maths stuff
Dim N As Long: Let N = Int((Ub - 1) / nRows) + 1 ' number of sub array

Rem 3 Loop to make array of arrays
Dim arrARays() As Variant ' for an array of arrays
ReDim arrARays(1 To N)
Dim Cnt As Long
    For Cnt = 1 To N
    ' 3a) Sub Array
    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(" & ((Cnt - 1) * nRows) + 1 & ":" & ((Cnt - 1) * nRows) + 1 + (nRows - 1) & ")"), Array(1))
    '3b) put sub array in array of array
     Let arrARays(Cnt) = arrOut()
    Next Cnt

Rem 4 ' arbritrary output range ( to match p45's ) 'print to sheet
Dim Destn As Range: Set Destn = ActiveSheet.Range("E1")
Dim littleArray As Variant
    For Each littleArray In arrARays()
     Let Destn.Resize(UBound(littleArray, 1), 1).Value = littleArray
     Set Destn = Destn.Offset(, 2)
    Next littleArray
End Sub

[YasserKhalil]

Thank you very much, Mr. Alan
Just one note, I got REF error at the end of the results sometimes and how can I specify the destination cells hardcoded in the code itself as the destination cells are not adjacent

[Doc.AElstein]

.... I got REF error at the end of the results sometimes ...

Yes, I expect that with the simplified macro ….. this is what I meant by …… If you can live with the last array not being truncated , then this would be a slightly simplified form ……
The simplified macro may be slightly faster, probably not much, but for that you will have errors in the last few elements of the last array.
If that is a problem for you then you will have to use my original macro.

_.______________________

how can I specify the destination cells hard coded in the code itself as the destination cells are not adjacent

The output I arranged to just be the same as p45’s macro, just for comparison.
You should be able to see that in both p45’s macro and mine we use arbitrarily E1 as the top left of where output starts.
The offset is set arbitrarily to 2 by this
Destn.Offset(, 2)
Change the 2 to 1 , and the outputs will be in adjacent columns

_.___________________

Note that my macro gives the results in an array of sub arrays. That cannot be pasted out in one go. So my macro loops to give the output

Code: Select all

 Rem 4 ' arbritrary output range ( to match p45's ) 'print to sheet
Dim Destn As Range: Set Destn = ActiveSheet.Range("E1")
Dim littleArray As Variant
    For Each littleArray In arrARays()
     Let Destn.Resize(UBound(littleArray, 1), 1).Value = littleArray
     Set Destn = Destn.Offset(, 2)
    Next littleArray

Each of the sub arrays (Each littleArray ) is pasted out at a time

[YasserKhalil]

Thanks a lot, Mr. Alan for your great support.

[Doc.AElstein]

If performance is important to you, then my macro ideas and solutions are , whilst very beautiful, probably not the way to go forward.
p45 has demonstrated that simple VBA looping way / Collection stuff works much better.
My gut feeling is also that for very large arrays my macro things will go a bit wonky/ slow, which p45’s measurements confirm..

But just out of academic interest,:
Here are some of the pretty ways….
In all these ways we make one final array that can be pasted out in one go. But you will have to live with those errors in the last column.

I start with a hard code macro, then make them dynamic.
I use the first small input range that we used, just to simplify the example, and for comparison, Ub = 25 and nRows = 7

Beauty1a
This is hard coded, just to help show what’s going on

Code: Select all

 Sub Beauty1a()
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("={1,8,15,22;2,9,16,23;3,10,17,24;4,11,18,25;5,12,19,26;6,13,20,27;7,14,21,28}"), Array(1))

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


End Sub

The main thing I am trying to demonstrate with all this , is that we can split an input array into pretty well any final array form that we want using the ..._
arrOut() = Index( arrIn() , Rows(), Clms() )
_... idea, and that furthermore we can often get the Rows() , Clms() with a bit of maths in one line, so that finally the whole thing can be done in a single code line….


Beauty1b - Beauty1d
The next 3 ( 4 ) macros do that last dynamically, that is to say, we can make that row indicia argument ( this bit Evaluate("={1,8,1……}" ) dynamic , and in a single code line

Beauty1b
This needs an extra Column Letter function because we use the Excel Column( ) function to get a “horizontal” array of numbers

Code: Select all

 Sub Beauty1b()
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:" & CL(Int((Ub - 1) / nRows) + 1) & ")-1)*" & nRows & ""), Array(1))

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

End Sub
'   https://excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort-Last-Row?p=7214&viewfull=1#post7214
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

Beauty1c
This does away with the need for the Column Letter function by transposing a Row( ) thing instead

Code: Select all

 Sub Beauty1c()
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)+(TRANSPOSE(ROW(1:4))-1)*7"), Array(1))
 Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(TRANSPOSE(ROW(1:" & Int((Ub - 1) / nRows) + 1 & "))-1)*" & nRows & ""), Array(1))

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

End Sub

Beauty1d
I don’t like the Transpose personally, and it can be replaced, but can take some effort to replace. This next macro version is especially beautiful, but only for academic interest ,
It shows that we can get an alternative to the Transpose, but then we are back to using the Column Function, so we are going around in circles, but it does show that we can do some things claimed to be impossible by the best people, such as getting an array out of a spreadsheet Index without embedding it in another function which uses the array but then only returns a single result.: I am using it to actually give out an array. It uses all the known tricks and a few more.
So Beauty1d is just for academic interest and future reference if we need to do something similar again.

I will have to include that in the next post…

[Doc.AElstein]

_... continued from last post
Beauty1d

Code: Select all

 Sub Beauty1d()
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)+(TRANSPOSE(ROW(1:" & Int((Ub - 1) / nRows) + 1 & "))-1)*7"), Array(1))
' Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(TRANSPOSE(ROW(1:4))-1)*7"), Array(1))
' Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(INDEX(ROW(1:4),COLUMN(A:D),COLUMN(A:D)/COLUMN(A:D))-1)*" & nRows & ""), Array(1))
 Let arrOut() = Application.Index(arrIn(), Evaluate("=ROW(1:7)+(If({1},INDEX(ROW(1:4),N(If(1,COLUMN(A:D))),N(If(1,COLUMN(A:D)))/N(If(1,COLUMN(A:D)))))-1)*" & nRows & ""), Array(1))
Rem 4 ' arbritrary output range
 Let Range("E1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()

End Sub

The development of those last few macros, in particular the getting at that row indicia array, can be seen in the attached file:

ItsAllSoBeautiful.xls

I guess this would be the simple final one line solution, just to show a bit more clearly for you….

Code: Select all

Sub Final()
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"


Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(TRANSPOSE(ROW(1:" & Int((Ub - 1) / nRows) + 1 & "))-1)*" & nRows & ""), Array(1))

End Sub

In other words. You put the input array, arrIn() and the nRows and the rows of the input array Ub in this code line to get the output in one go

Code: Select all

 
Range("E1").Resize(nRows, Int((Ub - 1) / nRows) + 1).Value = Application.Index(arrIn(), Evaluate("=ROW(1:" & nRows & ")+(TRANSPOSE(ROW(1:" & Int((Ub - 1) / nRows) + 1 & "))-1)*" & nRows & ""), Array(1))

_.______________________________________________________________________________________________


Alternatively we could build up that row indicia array by looping, It’s the same basic idea , but a bit simpler.

Code: Select all

 Sub Beauty2()
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 2 Do a column row loop to get the  Row()  indicia array
Dim Rws() As Long: ReDim Rws(1 To nRows, 1 To Int((Ub - 1) / nRows) + 1)
Dim Clm As Long
    For Clm = 1 To Int((Ub - 1) / nRows) + 1 ' Columns
        For Eye = 1 To nRows                 ' rows
         Let Rws(Eye, Clm) = Eye + ((Clm - 1) * nRows)
        Next Eye
    Next Clm

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 chucked back by  Index
     Let arrOut() = Application.Index(arrIn(), Rws(), Array(1))

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


End Sub

All those last few macros produce the same results: a single array which is then pasted out in one go, arbitrarily with top left at cell E1

SplitArraySingleOutput.JPG

[p45cal]

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