Thanks for your helps,
I have two arrays: A (100k row, 10 col) and B (100k row, 12 col)
The following code (thanks to BSALV) loop through A and B => It takes really long to finish. Is there any way to speedup.
ReDim Preserve B(1 To UBound(B), 1 To UBound(B, 2) + 4)
ReDim arr(1 To UBound(B), 1 To 2)
For i = 1 To UBound(B)
iSell = B(i, 3): mysold = 0
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
If IsNumeric(r) Then
For i1 = r To UBound(A)
If A(i1, 2) = B(i, 2) And A(i1, 1) <= B(i, 1) Then
x = Application.Max(0, Application.Min(A(i1, 3), iSell))
If x > 0 Then
mysold = mysold + x
iSell = iSell - x
MyValueSold = MyValueSold + x * A(i1, 4)
A(i1, 3) = A(i1, 3) - x
If A(i1, 3) <= 0 Then A(i1, 2) = "~"
End If
If A(i1, 3) > 0 Then Exit For
End If
Next
End If
arr(i, 1) = mysold: arr(i, 2) = MyValueSold
Next
This operation is really slow when using larger arrays:
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
You can get much better performance just by replacing the Index/Match line with a dictionary lookup.
To illustrate:
Sub Tester()
Const NROWS As Long = 100000
Dim i As Long, r, t
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim A(1 To NROWS, 1 To 10)
'populate some dummy data
For i = 1 To UBound(A, 1)
A(i, 2) = Application.RandBetween(1, NROWS)
A(i, 3) = i
Next i
'First your existing row lookup...
t = Timer
For i = 1 To 100 'only testing 100 lookups (too slow for more!)
r = Application.Match(i, Application.Index(A, 0, 2), 0)
Next i
Debug.Print "Index/Match lookup", Timer - t, "*100* lookups"
'populate a dictionary for lookups...
t = Timer
For i = 1 To NROWS
dict(A(i, 2)) = i 'mapping second column first occurences to row #
Next i
Debug.Print "Mapping done", Timer - t
'Now the dictionary lookup
t = Timer
For i = 1 To NROWS
If dict.Exists(i) Then
r = dict(i)
End If
Next i
Debug.Print "Dictionary lookup", Timer - t, NROWS & " lookups"
End Sub
Output:
Index/Match lookup 9.62 *100* lookups '<<< slow slow!
Mapping done 0.12
Dictionary lookup 0.26 100000 lookups
EDIT: changes in your existing code
Dim rngMatch As Range '<<< added
'...
'...
Set lo = Sheets("Exc").ListObjects("TBL_Buy")
Set rngMatch = lo.DataBodyRange.Columns(2) '<<< lookup range
With lo.Range
.Sort .Range("B1"), xlAscending, , .Range("A1"), xlAscending, Header:=xlYes
aBuy = lo.DataBodyRange.Value2
.Sort .Range("A1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes
End With
'...
For i = 1 To UBound(aResult)
'...
r = Application.Match(aResult(i, 2), rngMatch, 0) '<<<
'...
'...
Related
I'm trying to have a for loop that takes my weeks and then another for loop that looks at my product to calculate the sales for this year, last year and then the difference. I am getting 0's for all of the weeks except for the current week, any idea what is wrong with my code? Thanks
Sub Weekly_Recap()
Dim h, d As Worksheet
Dim myarray(), answers() As Variant
'Dim week, datarange As Range
Dim D1, i As Long
Set h = Worksheets("Helper")
Set d = Worksheets("Data")
myarray = d.Range("P2:P51")
D1 = UBound(myarray, 1)
ReDim answers(1 To D1, 1 To 3)
For i = 1 To D1
If myarray(i, 1) <= h.Range("A1") Then
For j = 1 To 17
answers(i, 1) = Application.WorksheetFunction.SumIfs(d.Range("G:G"), d.Range("B:B"), myarray(i, 1), d.Range("F:F"), h.Cells(j, 4))
answers(i, 2) = Application.WorksheetFunction.SumIfs(d.Range("H:H"), d.Range("B:B"), myarray(i, 1), d.Range("F:F"), h.Cells(j, 4))
answers(i, 3) = (answers(i, 1) - answers(1, 2)) / answers(i, 2)
If h.Cells(j, 4) = "FLAVORED/FUNCTIONAL WATER" Then
h.Range(h.Range("F2"), h.Range("F2").Offset(D1, 2)).Value = answers
ElseIf h.Cells(j, 4) = "SALTY BAGGED/CANISTER SNACKS" Then
h.Range(h.Range("K2"), h.Range("K2").Offset(D1, 2)).Value = answers
End If
Next j
End If
Next i
End Sub
Kinda hard to understand what you are trying to do. When I tried to run your code in debug mode I noticed that line with offset is overwriting data in previous lines, and that is where you are getting all 0's. In lets say loop i = 1 and j = 1 you get some value, but in i = 1 and j = 2 you don't (sumif returns 0) and then you overwrite it in variable answers and then paste it in worksheet, at the end only last one has not been overwritten.
You need swap the loops to calculate all the weeks for each product in turn otherwise the figure for week1/product1 will be overwritten by week1/product2 then week1/product3 etc.
Option Explicit
Sub Sales()
Dim arWeeks, NoOfWeeks As Long, iLastWeek As Long
Dim rngSales1 As Range, rngSales2 As Range
Dim rngWeek As Range, rngProduct As Range
Dim iWeek As Long, sProduct As String
Dim h As Worksheet, d As Worksheet
Dim j As Long, i As Long
Set h = Worksheets("Helper")
Set d = Worksheets("Data")
Set rngSales1 = d.Range("G:G")
Set rngSales2 = d.Range("H:H")
Set rngWeek = d.Range("B:B")
Set rngProduct = d.Range("F:F")
arWeeks = d.Range("P2:P51")
iLastWeek = h.Range("A1").Value
NoOfWeeks = UBound(arWeeks)
ReDim answers(1 To NoOfWeeks, 1 To 3) 'yr1,yr2,diff
For j = 1 To 17 ' products
sProduct = h.Cells(j, 4)
For i = 1 To NoOfWeeks ' weeks
iWeek = arWeeks(i, 1)
If iWeek <= iLastWeek Then
With Application.WorksheetFunction
answers(i, 1) = .SumIfs(rngSales1, rngWeek, iWeek, rngProduct, sProduct)
answers(i, 2) = .SumIfs(rngSales2, rngWeek, iWeek, rngProduct, sProduct)
End With
If answers(i, 2) <> 0 Then
answers(i, 3) = (answers(i, 1) - answers(1, 2)) / answers(i, 2)
End If
End If
Next i
If sProduct = "FLAVORED/FUNCTIONAL WATER" Then
h.Range("F2").Resize(NoOfWeeks, 3).Value = answers
ElseIf sProduct = "SALTY BAGGED/CANISTER SNACKS" Then
h.Range("k2").Resize(NoOfWeeks, 3).Value = answers
End If
Next j
MsgBox "Done ", vbInformation
End Sub
This compares a Customer Name and Part Number on sheet Temp (about 50 rows) to Customer Name and Part Number on sheet Data (about 20,000 rows). If the name and number are found in Data, then the associated information from that same row in Temp is added to Data.
This works great unless a name and number in Temp are not found in Data. When that occurs, a "Subscript out of range" error is generated. To me, it seems like the code is trying to find that value from Temp, and when it cannot find it, it just gives us and throws the error.
Can the code be revised to say, "Hey, if you cannot match a value, it's okay, just skip it and keep going"?
Sub MergeRMAArray()
'##############################################################################
' Creates arrays from "Temp RMA" & "Data" sheets, then compares rows on RMA and when a match occurs,
' pastes values in temp array. After loops, temp array values paste to "Data" sheet.
'##############################################################################
' If when processed there is an error, and the highlighted section states "Subscript out of range", with i+j
' being larger than the rows shown, then one potential error could be that a part on the RMA tab is not
' present in the Data tab, so the macro keeps searching. Will need to try and fix this on the next revision.
'##############################################################################
'##############################################################################
Set Data = Worksheets("Data")
Set Temp = Sheets("Temp RMA")
Data.Activate
Dim arrA, arrB, arrC As Variant
Dim i, j, k, LastRow2 As Long
LastRow = Data.Cells(Cells.Rows.Count, "A").End(xlUp).Row
LastRow2 = Temp.Cells(Cells.Rows.Count, "A").End(xlUp).Row
arrA = Data.Range("A2:B" & LastRow)
arrB = Temp.Range("A2:H" & LastRow2)
ReDim arrC(1 To LastRow - 1, 1 To 4)
For i = LBound(arrB) To UBound(arrB)
j = 0
For k = LBound(arrA) To UBound(arrA)
If (arrB(i, 1) = arrA(i + j, 1) _
And arrB(i, 2) = arrA(i + j, 2) _
And arrC(i + j, 1) = "") Then
arrC(i + j, 1) = arrB(i, 5)
arrC(i + j, 2) = arrB(i, 6)
arrC(i + j, 3) = arrB(i, 7)
arrC(i + j, 4) = arrB(i, 8)
Exit For
End If
j = j + 1
Next k
Next i
Range("W2").Resize(UBound(arrC, 1), UBound(arrC, 2)).Value = arrC
Erase arrA, arrB, arrC
End Sub
You are copying from "Temp" but arrC size is that of "Data". Need to change the Redim Statement. Also, J will reach 20000 each time (Data rows) at that point it will also add i which and then it will go beyond 20000 (Size of arrC) and hence the "Subscript out of Range" error.
Replace redim an loop with following.
m = 0
ReDim arrC(1 To LastRow2 - 1, 1 To 4)
For i = LBound(arrB, 1) To UBound(arrB, 1)
For j = LBound(arrA, 1) To UBound(arrA, 1)
If arrB(i, 1) = arrA(j, 1) _
And arrB(i, 2) = arrA(j, 2) Then
m = m + 1
arrC(m, 1) = arrB(i, 5)
arrC(m, 2) = arrB(i, 6)
arrC(m, 3) = arrB(i, 7)
arrC(m, 4) = arrB(i, 8)
End If
Next j
Next i
Looking at the number of loops in question (50*20,000 = 1000,000) and comparisons in arrays, suggesting following procedure using Range.Find method along with Range.Offset. This will cause much less loops and comparisons compared to those in the question.
Sub MergeRMAArray()
'##############################################################################
' "Temp RMA" & "Data" sheets, compares rows on RMA and when a match occurs,
' pastes values in temp sheet Columns E:H to "Data" sheet.
'##############################################################################
Dim Data As Worksheet: Set Data = Worksheets("Data")
Dim Temp As Worksheet: Set Temp = Sheets("Temp RMA")
Dim i As Long, j As Long, x As Long, y As Long, k As Long
Dim fRG As Range, outPut As Range, rw As Range
Dim dLR As Long: dLR = Data.Cells(Cells.Rows.Count, "A").End(xlUp).Row - 1
Dim tLR As Long: tLR = Temp.Cells(Cells.Rows.Count, "A").End(xlUp).Row - 1
Dim dRG As Range: Set dRG = Data.Range("A2:B" & dLR)
Dim tRG As Range: Set tRG = Temp.Range("A2:H" & tLR)
'Find the values in Temp sheet col A & B in Data sheet Col A & B
'If found union the range from corresponding row in Temp col E to H
For i = 1 To tLR '50 loops
On Error Resume Next
Set fRG = dRG.Columns(1).Find(What:=tRG(i, 1), After:=dRG(dRG.Rows.Count, 1), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not fRG Is Nothing Then
If tRG(i, 2) = fRG.Offset(0, 1) Then
If outPut Is Nothing Then
Set outPut = tRG(i, 1).Offset(0, 4).Resize(1, 4)
Else
Set outPut = Union(outPut, tRG(i, 1).Offset(0, 4).Resize(1, 4))
End If
End If
End If
Next
'Put all the outPut range values in arrC
Dim arrC
For Each Area In outPut.Areas 'max 50 loops
x = x + Area.Rows.Count
Next
y = outPut.Columns.Count
ReDim arrC(1 To x, 1 To y)
i = 0
For k = 1 To outPut.Areas.Count 'max 50*50 = 2500 loops
For Each rw In outPut.Areas(k).Rows
i = i + 1
arr = rw.Value
For j = 1 To y
arrC(i, j) = Split(Join(Application.Index(arr, 1, 0), "|"), "|")(j - 1)
Next
Next
Next
'Copy outPut values (stored in arrC) to Range("W2") in Data sheet
Data.Range("W2").Resize(x, y).Value = arrC
End Sub
i am trying to make a loop to go through an array(47193, 4) and an array 2 named attack(41892,1). The idea here is that the attack array has the values in order from the sheet i want to later on add the values to the next column, this is why i add the values to a third array. So the loop is going to go one by one the value from attack array while looping through arr array to find the common data. i tried copying the values directly to the sheet but excel freezes a lot. Now with this way, excel still freezes at this point. Is there anything wrong with it?
Dim arr3() As Variant
Dim dee As Long
ReDim arr3(UBound(attacks, 1), 1)
For k = 0 To UBound(attacks, 1)
j = 0
For j = 0 To UBound(arr, 1)
If attacks(k, 0) = arr(j, 0) And attacks(k, 1) = arr(j, 2) Then
arr3(dee, 0) = attacks(k, 0)
arr3(dee, 1) = attacks(k, 1)
de = dee + 1
End If
Next j
Next k
Here's some code showing how to use a Dictionary:
Sub Tester()
Const SZ As Long = 10000 'size of test arrays
Dim arr1(1 To SZ, 1 To 2)
Dim arr2(1 To SZ, 1 To 2)
Dim arr3(1 To SZ, 1 To 2) '<<matches go here
Dim n As Long, m As Long, i As Long, t, dict, k
t = Timer
'fill test arrays with random data
For n = 1 To SZ
arr1(n, 1) = CLng(Rnd * 200)
arr1(n, 2) = CLng(Rnd * 200)
arr2(n, 1) = CLng(Rnd * 200)
arr2(n, 2) = CLng(Rnd * 200)
Next n
Debug.Print "Filled test arrays", Timer - t
t = Timer
'test the nested loop approach
For n = 1 To SZ
For m = 1 To SZ
If arr1(n, 1) = arr2(m, 1) And arr1(n, 2) = arr2(m, 2) Then
i = i + 1
arr3(i, 1) = arr1(n, 1)
arr3(i, 2) = arr1(n, 2)
End If
Next m
Next n
Debug.Print "Finished nested loop", Timer - t, i & " matches"
t = Timer
'create a lookup using a dictionary
Set dict = CreateObject("scripting.dictionary")
For n = 1 To SZ
k = arr1(n, 1) & "|" & arr1(n, 2)
dict(k) = dict(k) + 1
Next n
Debug.Print "Filled dictionary", Timer - t
t = Timer
i = 0
Erase arr3
'Perform the match against arr2 using the dictionary
For m = 1 To SZ
k = arr2(m, 1) & "|" & arr2(m, 2)
If dict.exists(k) Then
i = i + 1
arr3(i, 1) = arr2(m, 1)
arr3(i, 2) = arr2(m, 2)
End If
Next m
Debug.Print "Finished dictionary loop", Timer - t, i & " matches"
End Sub
Output:
Filled test arrays 0
Finished nested loop 9.101563 2452 matches
Filled dictionary 0.03125
Finished dictionary loop 0.0078125 2177 matches
Note the # of matches is slightly different - the nested loop catches duplicate matches but the Dictionary only counts unique matches. You might need to make adjustments depending on your use case.
I want to alphabetically sort a 2-dimensional array results(lcol, 4) with VBA. This array contains 4 columns and variable number of rows, based on the values of the last column.
This is the code of how I populated the array :
ReDim results(lcol, 4)
For i = 1 To lcol
results(i, 1) = ThisWorkbook.Sheets(2).Range("B1").Offset(, i - 1).Value
results(i, 2) = "0"
results(i, 3) = ThisWorkbook.Sheets(3).Range("C2").Offset(i - 1, 0).Value
Next i
For Each of In ThisWorkbook.Sheets(1).Range("A1:C" & lrow2)
Set modele = of.Offset(, 1)
Set qte = of.Offset(, 2)
For Each modele2 In ThisWorkbook.Sheets(2).Range("A2:A481")
If modele2.Value = modele.Value Then
For i = 1 To lcol 'à modifier
results(i, 2) = results(i, 2) + qte.Value * modele2.Offset(, i).Value
If results(i, 2) <= results(i, 3) Then
results(i, 4) = "OK"
Else
results(i, 4) = "Rupture"
End If
Next i
Exit For
End If
Next modele2
Next of
This provides a basic (quiksort?) ascending sort on your populated array with the last column as the primary key.
dim i as long, j as long, tmp as variant
redim tmp(lbound(results, 1) to lbound(results, 1), lbound(results, 2) to ubound(results, 2))
for i = lbound(results, 1) to ubound(results, 1) - 1
if results(i, ubound(results, 2)) > results(i+1, ubound(results, 2)) or _
results(i, ubound(results, 2)) = vbnullstring then
for j = lbound(results, 2) to ubound(results, 2)
tmp(lbound(results, 1), j) = results(i, j)
next j
for j = lbound(results, 2) to ubound(results, 2)
results(i, j) = results(i+1, j)
next j
for j = lbound(results, 2) to ubound(results, 2)
results(i+1, j) = tmp(lbound(results, 1), j)
next j
end if
next i
Sorry for all the lbound and ubound but I had no idea if your array was zero-based of 1-based. The For i = 1 To lcol was not definitive. All evidence points to your arr being zero-based.
You could have SortedList object do the work
Assuming your results array is 1-based and with 4 columns, you could try the following code (UNTESTED):
Sub SortArray(results As Variant)
Dim i As Long, j As Long
With CreateObject("System.Collections.SortedList")
For i = 1 to UBound(results)
.Add results(i,4), Application.Index(result,i,0)
Next
For i = 1 To .Count
For j = 1 To 4
results(i, j) = .GetByIndex(i)(j)
Next
Next
End With
End Sub
Which you would call in your “main” sub as follows:
SortArray results
I am using VBA in Excel to consume an XML file and dump specific information into individual tabs. I want to be able to combine 2-dimensional arrays. The arrays have a "known" number of columns but an "unknown" number of rows. Consider the following two arrays:
array1:
a b c
d e f
array2:
1 2 3
4 5 6
How do I combine these to arrays if I want the following result:
array3:
a b c
d e f
1 2 3
4 5 6
And just out of curiosity, how would I code if instead I wanted to add to the right instead of the bottom, like this:
array4:
a b c 1 2 3
d e f 4 5 6
I can't seem to find the answer to this anywhere.
Please keep in mind my example above is rather small, but in reality, I'm trying to do this with approx 100,000 rows of data at once. There are only six columns of data, if that matters.
The goal here is to assemble a large array and then write it to an Excel sheet all in one step because when I do it in pieces the performance is really poor.
If possible, I'd prefer a solution that does not require iteration.
The reason I ask about both ways is that in reality I want to add kind of sequentially. For instance, assume I have four arrays, A, B, C, D.
First, add array A:
A
Then, add array B:
A B
Then, add array C:
A B
C
Then, add array D:
A B
C D
and so forth...
Keep in mind that each of the above arrays would be sized such that they "fit" correctly meaning A and B have the same number of rows, but different number of columns. A and C on the other hand have the same number of columns but a different number of rows. And so on...
I wanted to add a demonstration using Macro Man's code from below. Here is what he provided (I added a bit so readers can just copy/paste):
Option Explicit
Sub Testing()
Dim Array1(0 To 1, 0 To 2) As String
Array1(0, 0) = "a"
Array1(0, 1) = "b"
Array1(0, 2) = "c"
Array1(1, 0) = "d"
Array1(1, 1) = "e"
Array1(1, 2) = "f"
Dim Array2(0 To 1, 0 To 2) As String
Array2(0, 0) = "1"
Array2(0, 1) = "2"
Array2(0, 2) = "3"
Array2(1, 0) = "4"
Array2(1, 1) = "5"
Array2(1, 2) = "6"
Dim i As Long
For i = 1 To 25000
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array1, 1) - LBound(Array1, 1) + 1, _
UBound(Array1, 2) - LBound(Array1, 2) + 1).Value = Array1
End With
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array2, 1) - LBound(Array2, 1) + 1, _
UBound(Array2, 2) - LBound(Array2, 2) + 1).Value = Array2
End With
Next i
End Sub
When you run the above code, which goes back to the spreadsheet each time to write the small amount of data, this takes a long time to run. On my dual Xeon machine, like 25-30 seconds.
However, if you rewrite and populate the array FIRST, then write to the spreadsheet ONCE, it runs in about one second.
Option Explicit
Sub Testing()
Dim Array1(0 To 99999, 0 To 2) As String
Array1(0, 0) = "a"
Array1(0, 1) = "b"
Array1(0, 2) = "c"
Array1(1, 0) = "d"
Array1(1, 1) = "e"
Array1(1, 2) = "f"
Dim i As Long
For i = 0 To 99999
Array1(i, 0) = "a"
Array1(i, 1) = "b"
Array1(i, 2) = "c"
Next i
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array1, 1) - LBound(Array1, 1) + 1, _
UBound(Array1, 2) - LBound(Array1, 2) + 1).Value = Array1
End With
End Sub
I would like to see a solution which does the same thing, except being able to add "chunks" of data instead of individual items. Adding arrays to bigger arrays, ideally. Even better would be if the "parent" array somehow dynamically resized itself.
John Coleman's answer below worked great.
I actually combined a bit of Macro Man's with John's test() subroutine and this dynamically re-sizes the range:
Option Explicit
Sub test()
Dim A As Variant, B As Variant
ReDim A(0 To 1, 0 To 1)
ReDim B(0 To 1, 0 To 1)
A(0, 0) = 1
A(0, 1) = 2
A(1, 0) = 3
A(1, 1) = 4
B(0, 0) = 5
B(0, 1) = 6
B(1, 0) = 7
B(1, 1) = 8
Dim Array1 As Variant
Array1 = Combine(A, B)
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array1, 1) - LBound(Array1, 1) + 1, _
UBound(Array1, 2) - LBound(Array1, 2) + 1).Value = Array1
End With
End Sub
Here is a VBA function that can combine two 2-dimensional arrays into a single 2-dimensional array. It can be used either from VBA or as an array-formula directly in Excel. Iteration is unavoidable here in VBA since the language doesn't have primitives for things like concatenating arrays:
Function Combine(A As Variant, B As Variant, Optional stacked As Boolean = True) As Variant
'assumes that A and B are 2-dimensional variant arrays
'if stacked is true then A is placed on top of B
'in this case the number of rows must be the same,
'otherwise they are placed side by side A|B
'in which case the number of columns are the same
'LBound can be anything but is assumed to be
'the same for A and B (in both dimensions)
'False is returned if a clash
Dim lb As Long, m_A As Long, n_A As Long
Dim m_B As Long, n_B As Long
Dim m As Long, n As Long
Dim i As Long, j As Long, k As Long
Dim C As Variant
If TypeName(A) = "Range" Then A = A.Value
If TypeName(B) = "Range" Then B = B.Value
lb = LBound(A, 1)
m_A = UBound(A, 1)
n_A = UBound(A, 2)
m_B = UBound(B, 1)
n_B = UBound(B, 2)
If stacked Then
m = m_A + m_B + 1 - lb
n = n_A
If n_B <> n Then
Combine = False
Exit Function
End If
Else
m = m_A
If m_B <> m Then
Combine = False
Exit Function
End If
n = n_A + n_B + 1 - lb
End If
ReDim C(lb To m, lb To n)
For i = lb To m
For j = lb To n
If stacked Then
If i <= m_A Then
C(i, j) = A(i, j)
Else
C(i, j) = B(lb + i - m_A - 1, j)
End If
Else
If j <= n_A Then
C(i, j) = A(i, j)
Else
C(i, j) = B(i, lb + j - n_A - 1)
End If
End If
Next j
Next i
Combine = C
End Function
I tested it in 4 different ways. First I entered your two example arrays in the spreadsheets and used Combine directly in excel as an array formula:
Here A7:C10 contains the array formula
{=combine(A1:C2,A4:C5)}
and A12:F13 contains the array formula
{=combine(A1:C2,A4:C5,FALSE)}
Then, I ran the following sub:
Sub test()
Dim A As Variant, B As Variant
ReDim A(0 To 1, 0 To 1)
ReDim B(0 To 1, 0 To 1)
A(0, 0) = 1
A(0, 1) = 2
A(1, 0) = 3
A(1, 1) = 4
B(0, 0) = 5
B(0, 1) = 6
B(1, 0) = 7
B(1, 1) = 8
Range("A15:B18").Value = Combine(A, B)
Range("C15:F16").Value = Combine(A, B, False)
End Sub
Output:
If possible, I'd prefer a solution that does not require iteration.
Try this:
Function Combine(m, n)
Dim m1&, m2&, n1&, n2&
m1 = UBound(m, 1): m2 = UBound(m, 2)
n1 = UBound(n, 1): n2 = UBound(n, 2)
With Worksheets.Add
.[a1].Resize(m1, m2) = m
.[a1].Resize(n1, n2).Offset(m1) = n
Combine = .[a1].Resize(m1 + n1, m2)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Function
Note: this is just a demo to show proof of concept. Currently it does vertical stacking of two 2d arrays. Simple to modify to also do horizontal stacking.
Note: I'm typically opposed to this sort of thing, but if you think about it, an Excel sheet is analogous to a really big 2d array and while this is indeed a sleghammer approach, it is quick and there is no iteration!
You could try re-sizing the destination to match the array's dimensions. Something along the lines of:
(assuming your arrays are called 'Array1' and 'Array2')...
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array1, 1) - LBound(Array1, 1) + 1, _
UBound(Array1, 2) - LBound(Array1, 2) + 1).Value = Array1
End With
With Range("A" & Rows.Count).End(xlUp).Offset(IIf(IsEmpty([A1]), 0, 1), 0)
.Resize(UBound(Array2, 1) - LBound(Array2, 1) + 1, _
UBound(Array2, 2) - LBound(Array2, 2) + 1).Value = Array2
End With