VBA Excel - passing an array into a function - excel

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

Related

While trying to merge two matrices i'm getting a ref error. Any ideas on how to solve this?

Public Function v2(LeftMatrix As Range, RightMatrix As Range) As Variant()
Dim e As Integer, s As Integer
e = LeftMatrix.Rows.Count
s = LeftMatrix.Columns.Count
ReDim m(1 To e, 1 To s + 1)
Dim i As Integer, j As Integer, k As Integer
For i = 1 To e
For j = 1 To s + 1
If j <= s Then
m(i, j) = LeftMatrix(i, j)
Else
m(i, j) = RightMatrix(i, 1)
Next j
Next i
For i = 1 To e
For j = 1 To s + 1
Cells(i, j) = m(i, j)
Next j
Next i
End Function
I'm selecting two matrices from my worksheet and trying to merge them into a single matrix but I keep getting the ref error.

VBA ByRef argument type mismatch when using function in subroutine

I have a MatMul function for multiplying 2 matrices and returning the resulting Array. Gomb2_Click is triggered via a button and for each trigger it applies the transformation described by the matrix to the initial point p0.
(Both the matrix and the initial p0 point are hardcoded) \
In the Gomb2_Click subroutine the p1 = MatMul(mat, p0) line gives me a ByRef argument type mismatch error and I don't know why.
Thanks!
Function MatMul(a As Range, b As Range) As Range
If a.Columns.Count <> b.Rows.Count Then
MatMul = 0
End If
ReDim res(a.Rows.Count, b.Columns.Count)
For i = 1 To a.Rows.Count
For j = 1 To b.Columns.Count
tmp = 0
For k = 1 To a.Columns.Count
tmp = tmp + a(i, k) * b(k, j)
Next k
res(i - 1, j - 1) = tmp
Next j
Next i
MatMul = res
End Function
Dim colnum As Integer
Set colnum = 0
Dim p0 As Range
Set p0 = Range("B6:B7")
Dim mat As Range
Set mat = Range("B2:C3")
Sub Gomb2_Click()
Dim p1 as Variant
Set p1 = MatMul(mat, p0)
Range(Cells(6, 3 + colnum), Cells(7, 3 + colnum)).Value = p1
colnum = colnum + 1
p0.Value = p1
End Sub

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

Listing all possible combination without repetition,VBA

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.

Linear system solving ( N*N matrix multiplication ), VBA

I have 2 arrays. Array1 is n * n and Array2 is 1 * n.
These arrays are given in worksheets. In this case Sheet3 and Sheet4 and I need to output the answer on Sheet5.
I get multiple errors like "Subscript out of range".
I can't seem to figure out why this isn't working:
Public Sub LinearSystemSolver()
x = Sheet3.UsedRange.Rows.Count
y = Sheet3.UsedRange.Columns.Count
Z = Sheet4.UsedRange.Rows.Count
Dim a As Variant
ReDim a(1 To x, 1 To y)
Dim b As Variant
ReDim b(1 To Z, 1 To 1)
Dim g As Variant
ReDim g(1 To Z, 1 To 1)
For i = 1 To x
For j = 1 To y
a(i, j) = Sheet3.Cells(i, j)
Next
Next
For f = 1 To Z
b(f,1) = Sheet4.Cells(f,1)
Next
g = Application.WorksheetFunction.MMult((Application.WorksheetFunction.MInverse(a)), b)
For h = 1 To Z
Sheet5.Cells(h, 1) = g(h, 1)
Next
End Sub
You can speed up your code by assigning to the arrays directly and avoid loops
a = Sheet3.Range("A1").Resize(x,y).Value
b = Sheet4.Range("A1").Resize(z,1).Value
...
Sheet5.Range("A1").Resize(z,1).Value = g
Now as far as inverting the matrix (if x=y=z) the I propose to use LU decomposition. I have attached a working example which I have used for many years.
The driver code is
Private Sub solveButton_Click()
Dim lu As New LuSolver
' Get Matrix values and decompose them into L, U, P form
' Values are in B3 and matrix is a 5×5 size
lu.IntializeFromRange Range("B3"), 5
' Solve the A*x=b matrix system for x
' right hand side is in J3 and it is a 5×1 size
' resulting 5×1 matrix will be placed under H3
lu.Solve Range("J3"), 1, Range("H3")
End Sub
with the LU solver in a class called 'LuSolver"
'---------------------------------------------------------------------------------------
' Module : LuSolver
' DateTime : 6/30/2008 13:01
' Author : ja72
' Purpose : LU Decomposition of rectangular matrix.
' Remarks:
'For an n-by-n matrix A, the LU decomposition is an n-by-n
'unit lower triangular matrix L, an n-by-n upper triangular matrix U,
'and a permutation vector piv of length n so that A(piv)=L*U.
'---------------------------------------------------------------------------------------
Option Explicit
Private lu As Variant
Private sign As Integer
Private pivot() As Integer
Private size As Integer
Private Sub Class_Initialize()
Set lu = Nothing
Erase pivot
sign = 1
End Sub
Private Sub Class_Terminate()
Set lu = Nothing
Erase pivot
sign = 0
End Sub
Public Sub IntializeFromRange(ByRef r_coef As Range, ByVal matrix_size As Integer)
Dim k_max As Integer, k As Integer, p As Integer
Dim i As Integer, j As Integer
Dim s As Variant
On Error GoTo IntializeFromRange_Error
lu = r_coef.Resize(matrix_size, matrix_size).Value
size = matrix_size
'Set pivot as a sequence of integers
ReDim pivot(1 To size)
For i = 1 To size
pivot(i) = i
Next i
sign = 1
For j = 1 To size
'Apply previous transformations
For i = 1 To size
If j > i Then k_max = i Else k_max = j
s = 0
'Time consuming dot product
For k = 1 To k_max - 1
s = s + lu(i, k) * lu(k, j)
Next k
lu(i, j) = lu(i, j) - s
Next i
'Find the pivot element
p = j
For i = j + 1 To size
If Abs(lu(i, j)) > Abs(lu(p, j)) Then
p = i
End If
Next i
'Exchange pivot rows
If p <> j Then
For k = 1 To size
s = lu(p, k)
lu(p, k) = lu(j, k)
lu(j, k) = s
Next k
k = pivot(p)
pivot(p) = pivot(j)
pivot(j) = k
sign = -sign
End If
'Compute Multipliers
s = lu(j, j)
If j <= size And s <> 0 And s <> 1 Then
For i = j + 1 To size
lu(i, j) = lu(i, j) / s
Next i
End If
Next j
On Error GoTo 0
Exit Sub
IntializeFromRange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IntializeFromRange of Class Module LuDecomposition"
End Sub
Public Property Get IsSingular() As Boolean
IsSingular = Not IsNonSingular
End Property
Public Property Get IsNonSingular() As Boolean
IsNonSingular = True
Dim j As Integer
For j = 1 To size
If lu(j, j) = 0 Then
IsNonSingular = False
Exit Property
End If
Next j
End Property
Public Sub Solve(ByRef r_rhs As Range, ByVal no_of_columns, ByRef r_result As Range)
On Error GoTo Solve_Error
Dim rhs As Variant
Dim N As Integer, M As Integer, r As Integer
Dim i As Integer, j As Integer, k As Integer
N = size
M = size
r = no_of_columns
rhs = r_rhs.Resize(size, r).Value
'Copy rhs with pivoting
Dim X As Variant
ReDim X(1 To size, 1 To r)
For i = 1 To size
For j = 1 To r
X(i, j) = rhs(pivot(i), j)
Next j
Next i
'Solve L*Y = B
For k = 1 To M
For i = k + 1 To M
For j = 1 To r
X(i, j) = X(i, j) - X(k, j) * lu(i, k)
Next j
Next i
Next k
'Solve U*X=Y
For k = M To 1 Step -1
For j = 1 To r
X(k, j) = X(k, j) / lu(k, k)
Next j
For i = 1 To k - 1
For j = 1 To r
X(i, j) = X(i, j) - X(k, j) * lu(i, k)
Next j
Next i
Next k
r_result.Resize(size, no_of_columns).Value = X
On Error GoTo 0
Exit Sub
Solve_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Solve of Class Module LuDecomposition"
End Sub
In the following, loop Cells() needs two arguments:
For f = 1 To Z
b(f) = Sheet4.Cells(f)
Next
There may be other problems.

Resources