Listing all possible combination without repetition,VBA - excel

I have a code that work right now and lists numbers at 6 lenght.But they are repetive.But these numbers are repeated.I need unique non-repeated 6 digit.
I have this kind of results right now.1 1 1 3 4 6 but i need different and non repeating results.Thank you for helping me.
Sub AllCombinations()
Dim nums(): nums = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim arValues(999999, 5)
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, n5 As Integer, n6 As Integer, x As Long
For n1 = 0 To UBound(nums)
For n2 = 0 To UBound(nums)
For n3 = 0 To UBound(nums)
For n4 = 0 To UBound(nums)
For n5 = 0 To UBound(nums)
For n6 = 0 To UBound(nums)
arValues(x, 0) = nums(n1)
arValues(x, 1) = nums(n2)
arValues(x, 2) = nums(n3)
arValues(x, 3) = nums(n4)
arValues(x, 4) = nums(n5)
arValues(x, 5) = nums(n6)
x = x + 1
Next
Next
Next
Next
Next
Next
Range("A1").Resize(1000000, 6).Value2 = arValues
End Sub

As it stands, if you wanted to find combinations of different length or of an array with a different Ubound, you would have to alter your code. This can become very tedious and prone to error. Here is a more general solution that works for arrays of any type, any size, and any length of output.
Sub CombosNoRep(ByRef v() As Variant, r As Long)
Dim i As Long, k As Long, z() As Variant, comboMatrix() As Variant
Dim numRows As Long, numIter As Long, n As Long, count As Long
count = 1
n = UBound(v)
numRows = nChooseK(n, r)
ReDim z(1 To r)
ReDim comboMatrix(1 To numRows, 1 To r)
For i = 1 To r: z(i) = i: Next i
Do While (count <= numRows)
numIter = n - z(r) + 1
For i = 1 To numIter
For k = 1 To r: comboMatrix(count, k) = v(z(k)): Next k
count = count + 1
z(r) = z(r) + 1
Next i
For i = r - 1 To 1 Step -1
If Not (z(i) = (n - r + i)) Then
z(i) = z(i) + 1
For k = (i + 1) To r: z(k) = z(k - 1) + 1: Next k
Exit For
End If
Next i
Loop
Range("A1").Resize(numRows, r).Value2 = comboMatrix
End Sub
Function nChooseK(n As Long, k As Long) As Long
''returns the number of k-combinations from a set
''of n elements. Mathematically speaking, we have: n!/(k!*(n-k)!)
Dim temp As Double, i As Long
temp = 1
For i = 1 To k: temp = temp * (n - k + i) / i: Next i
nChooseK = CLng(temp)
End Function
Calling it we have:
Sub Test()
Dim myArray(1 To 9) As Variant, i As Long
For i = 1 To 9: myArray(i) = i: Next i
Call CombosNoRep(myArray, 6)
End Sub
This quickly outputs all 84 unique combinations.
Let's try it on an array with strings.
Sub Test()
Dim myArray() As Variant, i As Long
'' Added blank "" as CombosNoRep is expecting base 1 array
myArray = Array("", "Canada", "England", "Laos", "Ethiopia", "Burma", "Latvia", "Serbia", "Chile", "France", "Tonga")
Call CombosNoRep(myArray, 4)
End Sub
Here we have all 4-tuples of our array of countries (210 unique combinations).

Stagger the nested loops:
Sub AllCombinations()
Dim nums(): nums = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim arValues(999999, 5)
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, n5 As Integer, n6 As Integer, x As Long
For n1 = 0 To UBound(nums)
For n2 = n1 + 1 To UBound(nums)
For n3 = n2 + 1 To UBound(nums)
For n4 = n3 + 1 To UBound(nums)
For n5 = n4 + 1 To UBound(nums)
For n6 = n5 + 1 To UBound(nums)
arValues(x, 0) = nums(n1)
arValues(x, 1) = nums(n2)
arValues(x, 2) = nums(n3)
arValues(x, 3) = nums(n4)
arValues(x, 4) = nums(n5)
arValues(x, 5) = nums(n6)
x = x + 1
Next
Next
Next
Next
Next
Next
Range("A1").Resize(1000000, 6).Value2 = arValues
End Sub
for all 84 unique combinations.

Related

Finding and printing the lowest value number and its indexes from a newly generated matrix

The task I am doing requires to read and print a matrix from txt file, then create a new matrix B whose elements are the average of the row and column from A matrix, and then find the lowest valued number in the B matrix, print it and print its indexes (If the element "1" is the lowest and it is in the 2nd row and 3rd column, there should be printed below the matrix B "The lowest element is 1 with indexes 2;3".
For example the element B23 should be the average of the sum of the elements of row 2 and column 3 of matrix A. There is a short matrix example in the code below.
The input for the A matrix is coming from txt file, where on the first row are m and n (rows and columns) and below them is the actual matirx.
Example:
Thank you in advance!
Here is the code:
`
" Example for input
3 3
2 9 8
4 2 5
5 2 3
Expected answear:
Matrix A
2.00 9.00 8.00
4.00 2.00 5.00
5.00 2.00 3.00
Matrix B
15.00 16.00 17.50
11.00 12.00 13.50
10.50 11.50 13.00
The lowest element is 10.50 with indexes 3,1.
Option Explicit
Sub Matrix()
Dim m As Integer, n As Integer, A() As Single, _
MaxA As Single, r_Max As Integer
Call InputMatrix(m, n, A)
Call NewMatrixB(A, m)
End Sub
Sub InputMatrix(m As Integer, n As Integer, A() As Single)
Dim i As Integer, j As Integer
Dim FName As String
FName = InputBox("Vuvedete ime na fail s vhodni danni", _
"matrix", "H:\School\matrix.txt")
If Dir(FName) = "" Then
MsgBox ("Failut " & FName & " ne e nameren!")
Stop
End If
Close #1
Open FName For Input As #1
Input #1, m, n
ReDim A(m, n)
For i = 1 To m
For j = 1 To n
Input #1, A(i, j)
Next j
Next i
Close #1
Worksheets("Sheet1").Activate
Cells.Clear
Call OutMatrix(m, n, A, 1, "Matrix A")
End Sub
Sub OutMatrix(m As Integer, n As Integer, A() As Single, _
r As Integer, title As String)
Dim i As Integer, j As Integer
With Cells(r, 1)
.Value = title
.Font.Size = 14
.Font.Bold = True
End With
For i = 1 To m
For j = 1 To n
Cells(r + i, j).Value = A(i, j)
Cells(r + i, j).NumberFormat = "0.00"
Next j
Next i
End Sub
Sub NewMatrixB(Data As Variant, m As Integer)
Dim X As Variant
X = Data
Dim numRows As Long
Dim numCols As Long
numRows = UBound(X, 1)
numCols = UBound(X, 2)
ReDim rowSum(1 To numCols) As Double
ReDim colSum(1 To numRows) As Double
Dim r As Long
Dim c As Long
For r = 1 To numRows
For c = 1 To numCols
rowSum(c) = rowSum(c) + X(r, c)
colSum(r) = colSum(r) + X(r, c)
Next
Next
ReDim B(1 To numRows, 1 To numCols) As Double
For r = 1 To numRows
For c = 1 To numCols
B(r, c) = (rowSum(c) + colSum(r)) / 2
Next
Next
With Cells(m + 3, 1)
.Value = "Matrix B"
.Font.Size = 14
.Font.Bold = True
End With
Cells(m + 4, 1).Resize(numRows, numCols) = B
Worksheets("Sheet1").Range("A1:X100").NumberFormat = "0.00"
Dim Min As Integer
End Sub
Sub Minimum(m As Integer, Matrixxx As Single)
MsgBox Application.Min(Matrixxx)
End Sub
As far as I went, my code is up to the new matrix B and printing it, but I have trouble finding the new one and making it a type, where I can get the indexes as well. I also do have trouble with the syntacsis, Have been coding 5years ago in java.
If you need to return a value then define a function. To return more than one value use an array.
Option Explicit
Sub Process_Matrix()
' define matrices
Dim A As Variant, B As Variant
A = InputMatrix("matrix.txt") '"H:\School\matrix.txt")
Call OutMatrix("Matrix A", Sheet1.Cells(1, 1), A)
B = NewMatrixB(A)
Call OutMatrix("Matrix B", Sheet1.Cells(12, 1), B)
Dim idx, msg As String
idx = getMin(B)
msg = "Min = " & B(idx(0), idx(1)) & " at B(" & idx(0) & "," & idx(1) & ")"
MsgBox msg, vbInformation
End Sub
Function getMin(ByRef X) As Variant
Dim i As Long, j As Long, m As Double, ar(0 To 1) As Long
m = X(1, 1)
ar(0) = 1
ar(1) = 1
For i = 1 To UBound(X)
For j = 1 To UBound(X, 2)
If X(i, j) < m Then
m = X(i, j)
ar(0) = i
ar(1) = j
End If
Next
Next
getMin = ar
End Function
Function InputMatrix(Fname As String) As Variant
Dim i As Long, j As Long, m As Long, n As Long, A() As Single
Fname = InputBox("Vuvedete ime na fail s vhodni danni", _
"matrix", Fname)
If Dir(Fname) = "" Then
MsgBox "Failut " & Fname & " ne e nameren!", vbCritical
Stop
End If
Close #1
Open Fname For Input As #1
Input #1, m, n
ReDim A(1 To m, 1 To n)
For i = 1 To m
For j = 1 To n
Input #1, A(i, j)
Next j
Next i
Close #1
InputMatrix = A
End Function
Sub OutMatrix(title As String, rng As Range, ByRef X)
With rng
.Value = title
.Font.Size = 14
.Font.Bold = True
With .Offset(1, 0).Resize(UBound(X), UBound(X, 2))
.Value = X
.NumberFormat = "0.00"
End With
End With
End Sub
Function NewMatrixB(ByRef X) As Variant
Dim B, rowSum, colSum
Dim numRows As Long, numCols As Long, r As Long, c As Long
numRows = UBound(X, 1)
numCols = UBound(X, 2)
ReDim rowSum(1 To numRows) As Double
ReDim colSum(1 To numCols) As Double
For r = 1 To numRows
For c = 1 To numCols
rowSum(c) = rowSum(c) + X(r, c)
colSum(r) = colSum(r) + X(r, c)
Next
Next
ReDim B(1 To numRows, 1 To numCols) As Double
For r = 1 To numRows
For c = 1 To numCols
B(r, c) = (rowSum(c) + colSum(r)) / 2
Next
Next
NewMatrixB = B
End Function

VBA - Finding all order combinations and count

I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.

VBA Excel - passing an array into a function

I want to write a function in which I can include an array. I imagine that the function will work like the function NPV, we have 3 ways of specifying the syntax in the formula bar:
1) NPV(0.5, A1:A5)
2) NPV(0.5, A1, A2, A3, A4, A5)
3) NPV(0.5, {10, 20, 23, 25, 27})
Where 10, 20, 23, 25, 27 are the value in range A1:A5.
And here is my function in VBA:
Function MyNpv(r As Double, Flows As Variant)
Dim i, n As Integer
Dim p As Double
n = Application.Count(Flows)
For i = 1 To n
p = p + Flows(i) / (r + 1) ^ i
Next i
MyNpv = p
End Function
However, my own function can only work like:
MyNpv(0.5, A1:A5)
Is there anyway that I can declare my array so that it would work flexibly like the function NPV?
Thanks.
Use a ParamArray, Loop that to test what is in each part of the array and then adjust accordingly:
Function MyNpv(r As Double, ParamArray Flows() As Variant)
Dim FlowsPart As Variant
Dim p As Double
p = 0#
Dim k As Long
k = 1
For Each FlowsPart In Flows
Dim arr As Variant
arr = FlowsPart
Dim x As Long
x = -1
Dim y As Long
y = -1
On Error Resume Next
x = UBound(arr, 2)
y = UBound(arr)
On Error GoTo 0
Dim j As Long
Dim i As Long
If x >= 0 And y >= 0 Then
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
p = p + arr(i, j) / (r + 1) ^ k
k = k + 1
Next j
Next i
ElseIf y >= 0 Then
For j = LBound(arr) To UBound(arr)
p = p + arr(j) / (r + 1) ^ k
k = k + 1
Next j
Else
p = p + arr / (r + 1) ^ k
k = k + 1
End If
Next FlowsPart
MyNpv = p
End Function

Poker Dealer Logic

I'd like to use Excel as my poker dealer. Here is the code that will generate 20 random numbers (cards) between 1 and 52. Output of first 20 numbers/cards is in column A1:A20. I'd like to have the next set of 20 numbers/cards generated in A22:A41, 3rd A43:A62, and so on. How can the code be fixed so that it displays 1000 hands in column A with one row separating each set? Thank you.
Sub cards()
Range("A:A").Clear
cardstodraw = 20
For x = 1 To cardstodraw
begL:
ActiveSheet.Cells(1, 2) = "=Randbetween(1,52)"
ActiveSheet.Cells(x, 1) = ActiveSheet.Cells(1, 2).Text
cardvalue = ActiveSheet.Cells(x, 1)
y = 1
Count = 0
Do Until ActiveSheet.Cells(y, 1) = ""
If ActiveSheet.Cells(y, 1) = cardvalue Then
Count = Count + 1
End If: y = y + 1: Loop
If Count > 1 Then GoTo begL
Next
Range("B1").Clear
End Sub
Your code is somewhat convoluted (using GoTo is usually an indication that something can be improved). For getting a sample of size 20 from 1-52, use a modified Fisher-Yates shuffle:
Option Explicit 'you really should be using this
Function deal(n As Long, k As Long) As Variant
'returns an array of length k
'consisting of k numbers in the range 1 to n
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k)
deal = deck
End Function
If you want to have 1000 hands in Column A:
Sub ManyHands()
Dim i As Long
With Application.WorksheetFunction
For i = 1 To 1000
Range(Cells(1 + 21 * (i - 1), 1), Cells(21 * i - 1, 1)).Value = .Transpose(deal(52, 20))
Next i
End With
End Sub
On Edit Here is a modified version of the code, one which deals cards to multiple players:
Function deal(n As Long, k As Long, players As Long) As Variant
'returns an array with k rows and players columns
'consisting of k*players numbers in range 1 to n
'if players = 1, then the array is 1-dimensional
'otherwise it is 2-dimensional
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
Dim hands As Variant
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k*players steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k * players, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k * players)
If players = 1 Then
deal = deck
Exit Function
Else
ReDim hands(1 To k, 1 To players)
For i = 1 To k
For j = 1 To players
hands(i, j) = deck(players * (i - 1) + j)
Next j
Next i
deal = hands
End If
End Function
It could be used like:
Sub ManyHands()
Dim i As Long
For i = 1 To 1000
Range(Cells(1 + 11 * (i - 1), 1), Cells(11 * i - 1, 2)).Value = deal(52, 10, 2)
Next i
End Sub
Try:
Sub cards()
Dim cardstodraw As Long, numberofhands As Long, i As Long, j As Long, k As Long
cardstodraw = 20
numberofhands = 50
Range("A:A").Clear
With Application.WorksheetFunction
For j = 0 To numberofhands - 1
For i = 1 To cardstodraw
begL:
Cells(i + k + (j * cardstodraw), 1) = .RandBetween(1, 52)
If .CountIf(Range(Cells(1 + k + (j * cardstodraw), 1), Cells(20 + k + (j * cardstodraw), 1)), Cells(i + k + (j * cardstodraw), 1)) > 1 Then GoTo begL
Next i
k = k + 1
Next j
End With
End Sub

Excel vba - joining two arrays

I need to join two arrays vd and vd1 into vdu.
ReDim vdu(1 To (UBound(vd, 1) + UBound(vd1, 1)), 1 To 1)
For i = 1 To UBound(vd, 1)
vdu(i, 1) = vd(i, 1)
Next i
For j = i To UBound(vdu, 1)
vdu(j, 1) = vd1(j - i + 1, 1)
Next j
First, I get and "out of range" error.
Second, in the end I will have 18 arrays that I'll need to join, so I don't know if this is the best idea for joining them.
try with
ReDim vdu(LBound(vd) To UBound(vd) + UBound(vd1), 1 To 1)
For i = LBound(vdu) To UBound(vdu)
If i <= UBound(vd) Then
vdu(i, 1) = vd(i, 1)
Else
vdu(i, 1) = vd1(i - UBound(vd), 1)
End If
Next i
Update for second part of question
I'd convert your merge code into a function
Public Function MergeArrays(arr1 As Variant, arr2 As Variant) As Variant
Dim i As Long
Dim arr As Variant
ReDim arr(LBound(arr1, 1) To UBound(arr1, 1) + UBound(arr2, 1), 1 To 1)
For i = LBound(arr, 1) To UBound(arr, 1)
If i <= UBound(arr1, 1) Then
arr(i, 1) = arr1(i, 1)
Else
arr(i, 1) = arr2(i - UBound(arr1, 1), 1)
End If
Next i
MergeArrays = arr
End Function
And then pass each array to it 1 at a time e.g.
arr = MergeArrays(vd1, vd2)
arr = MergeArrays(arr, vd3)
arr = MergeArrays(arr, vdx)
You could loop through this by storing your arrays in an array or dictionary and looping through that instead as well
Other option
Public Function MergeArrays(ParamArray arrays() As Variant) As Variant
Dim i As Long, j As Long, cnter As Long, UBoundArr As Long, OldUBoundArray As Long
Dim arr() As Variant
For j = LBound(arrays) To UBound(arrays)
UBoundArr = UBoundArr + UBound(arrays(j), 1)
Next j
ReDim arr(1 To UBoundArr, 1 To 1)
For j = LBound(arrays) To UBound(arrays)
For i = LBound(arrays(j)) To UBound(arrays(j))
arr(i + OldUBoundArray, 1) = arrays(j)(i, 1)
Next i
OldUBoundArray = OldUBoundArray + UBound(arrays(j), 1)
Next j
MergeArrays = arr
End Function
This method uses a ParamArray. If you're not sure what that is look it up but effectively you're able to pass an unspecified amount of arguments to the function. Therefore with this function you can combine any amount of arrays (of the same shape and same base i.e. x to x, 1 to 1) and it will combine them. Call like
arr = MergeArrays(vd, vd1, vd2,....,vd18)
getMasterArray will return an array that combines up to 60 different 2d arrays into one. getMasterArray also give you the option of returning a 0 or based array.
Sub TestgetMasterArray()
Dim data
data = getMasterArray(False, Range("List1").Value, Range("List2").Value, Range("List3").Value, Range("List4").Value)
Worksheets("Result").Range("A1").Resize(UBound(data), UBound(data, 2)).Value = data
End Sub
Function getMasterArray(Base0 As Boolean, ParamArray Arrays() As Variant)
Dim result As Variant, v As Variant
Dim Count As Long, Count2 As Long, lowBound As Integer, lOffset As Integer, x As Long, x1 As Long, y As Long
For Each v In Arrays
Count = Count + UBound(v) + IIf(LBound(v) = 0, 1, 0)
y = UBound(v, 2) + IIf(LBound(v, 2) = 0, 1, 0)
If y > Count2 Then Count2 = y
Next
lowBound = IIf(Base0, 0, 1)
ReDim result(lowBound To Count, lowBound To Count2)
For Each v In Arrays
If LBound(v, 2) > LBound(result, 2) Then
lOffset = -1
ElseIf LBound(v, 2) < LBound(result, 2) Then
lOffset = 1
End If
For x = LBound(v) To UBound(v)
For y = LBound(v, 2) To UBound(v, 2)
result(lowBound, y + lOffset) = v(x, y)
Next
lowBound = lowBound + 1
Next
Next
getMasterArray = result
End Function
Sample data generated by ockaroo.com

Resources