Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
"Alan Beban" wrote...
.... . . . 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
Harlan Grove wrote:
"Alan Beban" wrote... ... . . . no add-in required. . . . Perhaps not, but VBA required. Duh! Alan Beban |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
Harlan Grove wrote:
"Alan Beban" wrote... ... 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. . . . 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
Harlan Grove wrote:
. . . 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Extracting sub arrays from a 2-D VBA array
"Alan Beban" wrote...
Harlan Grove wrote: ... And collapsing arbitrary partial 2D arrays, .... 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? |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
OT- the competitive urge?
You must enjoy being driven into the ground head first. .....
I suppose you two are good friends? Regards Robert McCurdy "Harlan Grove" wrote in message ... "Alan Beban" wrote... Harlan Grove wrote: ... And collapsing arbitrary partial 2D arrays, ... Similarly, with a single call (again, given the hardcoding): Function SubArrayFormula4(InputArray) ... You must enjoy being driven into the ground head first. Try this. |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
OT- the competitive urge?
ROTFLMAO!
Alan Beban Robert McCurdy wrote: You must enjoy being driven into the ground head first. ..... I suppose you two are good friends? Regards Robert McCurdy |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
SUMPRODUCT function for two arrays. Array 1 contains text | Excel Worksheet Functions | |||
RENEWED-- Arrays: Counting multiple values within array | Excel Worksheet Functions | |||
Creating a single vertical array from multiple column arrays | Excel Worksheet Functions | |||
Two arrays need highlight duplicate in one of the array | Excel Worksheet Functions | |||
extracting a subset of an array with VBA. | Excel Programming |