Extracting sub arrays from a 2-D VBA array

[Alan Beban]

Posters often ask how a sub array of a 2-D array can be created. I have
often referred to the SubArray function in the freely downloadable file
at http://home.pacbell.net/beban. There follows some code that will
accomplish the same thing for a 2-D array that is not too large to fit
on a single worksheet (i.e., 65536x256); no add-in required. It
involves transferring the array to a worksheet, extracting the sub array
to a second worksheet by means of an array formula, and then writing the
sub array range to a VBA array. I have run *no* tests to explore speed
of execution.

Sub SubArrayFormula(InputArray, row1, row2, col1, col2)
Dim rng1 As Range, rng2 As Range,icol1 As Long, icol2 As Long
Dim MySubArray As Variant
Worksheets.Add
ActiveSheet.Name = "xyz1"
Set rng1 = Range("a1").Resize(UBound(InputArray) _
-LBound(InputArray) + 1, _
UBound(InputArray, 2) - LBound(InputArray, 2) + 1)
rng1.Value = InputArray
Worksheets.Add
ActiveSheet.Name = "xyz2"
Set rng2 = Range("A1").Resize(row2 - row1 + 1, col2 - col1 + 1)
Select Case col1
Case Is < 27
icol1 = Chr(64 + col1)
Case Is < 53
icol1 = "A" & Chr(64 + col1 - 26)
Case Is < 79
icol1 = "B" & Chr(64 + col1 - 52)
Case Is < 105
icol1 = "C" & Chr(64 + col1 - 78)
Case Is < 131
icol1 = "D" & Chr(64 + col1 - 104)
Case Is < 157
icol1 = "E" & Chr(64 + col1 - 130)
Case Is < 183
icol1 = "F" & Chr(64 + col1 - 156)
Case Is < 209
icol1 = "G" & Chr(64 + col1 - 182)
Case Is < 235
icol1 = "H" & Chr(64 + col1 - 208)
Case Is < 257
icol1 = "I" & Chr(64 + col1 - 234)
End Select
Select Case col2
Case Is < 27
icol2 = Chr(64 + col2)
Case Is < 53
icol2 = "A" & Chr(64 + col2 - 26)
Case Is < 79
icol2 = "B" & Chr(64 + col2 - 52)
Case Is < 105
icol2 = "C" & Chr(64 + col2 - 78)
Case Is < 131
icol2 = "D" & Chr(64 + col2 - 104)
Case Is < 157
icol2 = "E" & Chr(64 + col2 - 130)
Case Is < 183
icol2 = "F" & Chr(64 + col2 - 156)
Case Is < 209
icol2 = "G" & Chr(64 + col2 - 182)
Case Is < 235
icol2 = "H" & Chr(64 + col2 - 208)
Case Is < 257
icol2 = "I" & Chr(64 + col2 - 234)
End Select
rng2.FormulaArray = "=INDEX(xyz1!" & rng1.Address & _
",ROW(" & row1 & ":" & row2 & "),COLUMN(" & icol1 & ":" & _
icol2 & "))"
MySubArray = rng2.Value
Application.DisplayAlerts = False
Sheets("xyz1").Delete
Sheets("xyz2").Delete
Application.DisplayAlerts = True
End Sub

It arose out of exploring ways to return non-contiguous columns from a
VBA array.

Alan Beban

 

[Harlan Grove]

. . . no add-in required. . . .

Perhaps not, but VBA required.

. . . It
involves transferring the array to a worksheet, extracting the sub array
to a second worksheet by means of an array formula, and then writing the
sub array range to a VBA array. I have run *no* tests to explore speed
of execution.

Sub SubArrayFormula(InputArray, row1, row2, col1, col2)
Dim rng1 As Range, rng2 As Range,icol1 As Long, icol2 As Long
Dim MySubArray As Variant
Worksheets.Add
ActiveSheet.Name = "xyz1"

....

So you're unfamiliar with storing the result of the Add method, which is
just a function call returning a worksheet object, in a variable?

Dim ws As Worksheet
Set ws = Worksheets.Add

Then you wouldn't need to bother naming that worksheet to keep track of it.

Select Case col1
Case Is < 27
icol1 = Chr(64 + col1)

....

This is *MUCH* easier when you use R1C1 addressing.

rng2.FormulaArray = "=INDIRECT(""xyz1!R" & row1 & "C" & col1 _
& ":R" & row2 & "C" & col2 & """,0)"

MySubArray = rng2.Value
Application.DisplayAlerts = False
Sheets("xyz1").Delete
Sheets("xyz2").Delete
Application.DisplayAlerts = True
End Sub

And your reason for not assigning this *directly* to MySubArray using
Evaluate is what, precisely?

MySubArray = Evaluate("=INDIRECT(""xyz1!R" & row1 & "C" & col1 _
& ":R" & row2 & "C" & col2 & """,0)")

This would eliminate the 'need' for the second worksheet.

Also, your proc lack any means of passing MySubArray back to the calling
proc, so does nothing other than waste cycles. So it's purpose was what,
precisely?

It arose out of exploring ways to return non-contiguous columns from a
VBA array.

Colapsing 2D VBA arrays by removing unwanted columns? The following would
seem simpler, and is almost certainly faster than repeated calls to anything
like your proc.

'assumes 2D array a already exists, and desired
'columns from a specified in 1D array wc
'
Dim wc As Variant, b As Variant
Dim i As Long, j As Long, n As Long

wc = Array(1, 3, 5, 7)
n = UBound(wc, 1)

ReDim b(LBound(a, 1) To UBound(a, 1), 1 To n + 1)

For i = LBound(a, 1) To UBound(a, 1)
For j = 0 To n
b(i, j + 1) = a(i, wc(j))
Next j
Next i


And colapsing arbitrary partial 2D arrays,

Dim wc As Variant, wr As Variant, b As Variant
Dim i As Long, j As Long, m As Long, n As Long

wr = Array(2, 4, 6, 8, 10, 11, 12)
m = UBound(wr, 1)
wc = Array(1, 3, 5, 7)
n = UBound(wc, 1)

ReDim b(1 To m + 1, 1 To n + 1)

For i = 0 To m
For j = 0 To n
b(i + 1, j + 1) = a(wr(i), wc(j))
Next j
Next i

 

[Alan Beban]

Perhaps not, but VBA required.

Duh!

Alan Beban

 

[Alan Beban]

...




Colapsing 2D VBA arrays by removing unwanted columns? The following would
seem simpler, and is almost certainly faster than repeated calls to anything
like your proc. . . .

Well, it might certainly be faster than even a single call to a
procedure, but if you're willing to hardcode the columns to be
extracted, as you do with wc, it doesn't require *repeated* calls; e.g.,

Function SubArrayFormula3(InputArray)
numRows = UBound(InputArray) - LBound(InputArray) + 1
numCols = UBound(InputArray, 2) - LBound(InputArray, 2) + 1
Worksheets.Add
ActiveSheet.Name = "xyz1"
Set rng1 = Range("a1").Resize(numRows, numCols)
rng1.Value = InputArray
Worksheets.Add
ActiveSheet.Name = "xyz2"
Set rng2 = Range("A1").Resize(numRows, 3)
rng2.FormulaArray = "=INDEX(xyz1!" & rng1.Address & ",ROW(1:" &
numRows & "),{2,3,5})"
SubArrayFormula3 = rng2.Value
Application.DisplayAlerts = False
Sheets("xyz1").Delete
Sheets("xyz2").Delete
Application.DisplayAlerts = True
End Function

'assumes 2D array a already exists, and desired
'columns from a specified in 1D array wc
'
Dim wc As Variant, b As Variant
Dim i As Long, j As Long, n As Long

wc = Array(1, 3, 5, 7)
n = UBound(wc, 1)

ReDim b(LBound(a, 1) To UBound(a, 1), 1 To n + 1)

For i = LBound(a, 1) To UBound(a, 1)
For j = 0 To n
b(i, j + 1) = a(i, wc(j))
Next j
Next i

Alan Beban

 

[Alan Beban]

. . .
And collapsing arbitrary partial 2D arrays,

Dim wc As Variant, wr As Variant, b As Variant
Dim i As Long, j As Long, m As Long, n As Long

wr = Array(2, 4, 6, 8, 10, 11, 12)
m = UBound(wr, 1)
wc = Array(1, 3, 5, 7)
n = UBound(wc, 1)

ReDim b(1 To m + 1, 1 To n + 1)

For i = 0 To m
For j = 0 To n
b(i + 1, j + 1) = a(wr(i), wc(j))
Next j
Next i

Similarly, with a single call (again, given the hardcoding):

Function SubArrayFormula4(InputArray)
numRows = UBound(InputArray) - LBound(InputArray) + 1
numCols = UBound(InputArray, 2) - LBound(InputArray, 2) + 1
Worksheets.Add
ActiveSheet.Name = "xyz1"
Set rng1 = Range("a1").Resize(numRows, numCols)
rng1.Value = InputArray
Worksheets.Add
ActiveSheet.Name = "xyz2"
Set rng2 = Range("A1").Resize(7, 4)
rng2.FormulaArray = "=INDEX(xyz1!" & rng1.Address & _
",{2;4;6;8;10;11;12},{1,3,5,7})"
SubArrayFormula4 = rng2.Value
Application.DisplayAlerts = False
Sheets("xyz1").Delete
Sheets("xyz2").Delete
Application.DisplayAlerts = True
End Function

Alan Beban

 

[Harlan Grove]

....
Similarly, with a single call (again, given the hardcoding):

Function SubArrayFormula4(InputArray)

....

You must enjoy being driven into the ground head first. Try this.

Note: both hgsa and absa functions assume array a is 2D and 1-based. Also,
both provide no error checking.


Sub testem()
Const MAXITER As Long = 10000

Dim inct As Date, cumt As Date, n As Long
Dim a As Variant, b As Variant

a = [Sheet2!A1:J25].Value 'fill with whatever you want

cumt = 0
For n = 1 To MAXITER
inct = Timer
b = hgsa(a, Array(1, 2, 3, 5, 7, 11, 13, 17, 19, 23), _
Array(2, 4, 6, 7, 8))
cumt = cumt + Timer - inct
Erase b 'no need to time implicity garbage collection
Next n
Debug.Print "HG: " & Format(cumt, "0.00")

cumt = 0
For n = 1 To MAXITER / 100 '*** NOTE DIVISION BY 100! ***
inct = Timer
b = absa(a, Array(1, 2, 3, 5, 7, 11, 13, 17, 19, 23), _
Array(2, 4, 6, 7, 8))
cumt = cumt + Timer - inct
Erase b 'no need to time implicity garbage collection
Next n
Debug.Print "AB: " & Format(cumt, "0.00")

Debug.Print String(30, "-")
End Sub


Function hgsa(a As Variant, wr As Variant, wc As Variant) As Variant
Dim rv As Variant
Dim i As Long, j As Long, ii As Long, jj As Long
Dim m As Long, n As Long

m = UBound(wr, 1) - LBound(wr, 1) + 1
n = UBound(wc, 1) - LBound(wc, 1) + 1

ReDim rv(1 To m, 1 To n)

ii = LBound(wr, 1)
For i = 1 To m
jj = LBound(wc, 1)
For j = 1 To n
rv(i, j) = a(wr(ii), wc(jj))
jj = jj + 1
Next j
ii = ii + 1
Next i

hgsa = rv
End Function


Function absa(a As Variant, wr As Variant, wc As Variant) As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, r1 As Range, r2 As Range
Dim f As String, i As Long

On Error GoTo CleanUp
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

ReDim rv(1 To UBound(wr, 1) - LBound(wr, 1) + 1, _
1 To UBound(wc, 1) - LBound(wc, 1) + 1)

Set ws1 = Worksheets.Add
Set r1 = ws1.Range("A1").Resize(UBound(a, 1), UBound(a, 2))
r1.Value = a

f = "=INDEX(" & r1.Address(0, 0, xlA1, 1) & ",{"
For i = LBound(wr, 1) To UBound(wr, 1) - 1
f = f & Format(wr(i)) & ";"
Next i
f = f & Format(wr(UBound(wr, 1))) & "},{"
For i = LBound(wc, 1) To UBound(wc, 1) - 1
f = f & Format(wc(i)) & ","
Next i
f = f & Format(wc(UBound(wc, 1))) & "})"

Set ws2 = Worksheets.Add
Set r2 = ws2.Range("A1").Resize(UBound(wr, 1) - LBound(wr, 1) + 1, _
UBound(wc, 1) - LBound(wc, 1) + 1)
r2.FormulaArray = f

absa = r2.Value

CleanUp:
Application.DisplayAlerts = False
If Not ws1 Is Nothing Then ws1.Delete
If Not ws2 Is Nothing Then ws2.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function


Go on, test 'em. I have, and on my PC your approach runs MORE THAN *TWO*
DECIMAL ORDERS OF MAGNITUDE SLOWER. That's not a minor difference. And
that's *after* turning off screen updating.

You have remarkably poor instincts when it comes to runtime efficiency. I
don't see how you could have consciously engineered a slower way to do this.
But in the off chance I'm being unfair, why don't you see if there's some
way you could modify the absa function to run faster while leaving it able
to accept arbitrary (but implicitly assumed valid) wr and wc arguments.

If you can't improve the efficiency of absa, will you abandon this approach?

 

[Robert McCurdy]

You must enjoy being driven into the ground head first. .....

I suppose you two are good friends?


Regards
Robert McCurdy

 

[Alan Beban]

ROTFLMAO!

Alan Beban

I suppose you two are good friends?


Regards
Robert McCurdy