Split 2d array into multiple equal 2d arrays
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Split 2d array into multiple equal 2d arrays
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
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
-
- Administrator
- Posts: 78416
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Split 2d array into multiple equal 2d arrays
Why not simply copy parts of the range in a loop?
Best wishes,
Hans
Hans
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
Because the original 2d array is part of a code not directly in a worksheet.
-
- Administrator
- Posts: 78416
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Split 2d array into multiple equal 2d arrays
You could fill a range with the array...
Best wishes,
Hans
Hans
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
Does that mean to create a temp worksheet then to put the main output array then dealing with it?
-
- Administrator
- Posts: 78416
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
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?
-
- Administrator
- Posts: 78416
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Split 2d array into multiple equal 2d arrays
Let's see if DocAElstein has a suggestion, he seems to like such stuff.
Best wishes,
Hans
Hans
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
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
-
- 2StarLounger
- Posts: 144
- Joined: 11 Jun 2012, 20:37
Re: Split 2d array into multiple equal 2d arrays
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:
and
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.
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
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
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.
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Split 2d array into multiple equal 2d arrays
How does the saying go…… I missed the distant call of my name in vain … :)
_.____________________________
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
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…..
Same macro but with Ub=70 , nRows=25YasserKhalil wrote: ↑19 Nov 2021, 13:49Example: 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....
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
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- 2StarLounger
- Posts: 144
- Joined: 11 Jun 2012, 20:37
Re: Split 2d array into multiple equal 2d arrays
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
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
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
Amazing p45cal and Mr. Alan
Thank you very much for these awesome contributions.
Thank you very much for these awesome contributions.
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Split 2d array into multiple equal 2d arrays
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
( 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
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
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
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
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Split 2d array into multiple equal 2d arrays
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 ……YasserKhalil wrote: ↑22 Nov 2021, 10:55.... I got REF error at the end of the results sometimes ...
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.
_.______________________
The output I arranged to just be the same as p45’s macro, just for comparison.YasserKhalil wrote: ↑22 Nov 2021, 10:55how can I specify the destination cells hard coded in the code itself as the destination cells are not adjacent
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
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- PlatinumLounger
- Posts: 4913
- Joined: 31 Aug 2016, 09:02
Re: Split 2d array into multiple equal 2d arrays
Thanks a lot, Mr. Alan for your great support.
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
The Pretty ways....
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
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
Beauty1c
This does away with the need for the Column Letter function by transposing a Row( ) thing instead
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…
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
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
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
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…
Last edited by Doc.AElstein on 22 Nov 2021, 21:17, edited 6 times in total.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- BronzeLounger
- Posts: 1499
- Joined: 28 Feb 2015, 13:11
- Location: Hof, Bayern, Germany
Re: Split 2d array into multiple equal 2d arrays - The pretty ways
_... continued from last post
Beauty1d
The development of those last few macros, in particular the getting at that row indicia array, can be seen in the attached file:
I guess this would be the simple final one line solution, just to show a bit more clearly for you….
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
_.______________________________________________________________________________________________
Alternatively we could build up that row indicia array by looping, It’s the same basic idea , but a bit simpler.
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
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:
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
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
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also
You can find me at DocAElstein also
-
- 2StarLounger
- Posts: 144
- Joined: 11 Jun 2012, 20:37
Re: Split 2d array into multiple equal 2d arrays
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.
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.