Trying to debug. My best guess is the array indexing is a problem.
Public Function CFR(df(), x As Double, t As Integer) As Double
Dim i, y As Integer
Dim discount()
Dim nom, denom As Double
ReDim discount(t) As Double
y = 1
For i = UBound(df, 1) + 1 To t
discount(i) = df(UBound(df, 1)) * (x ^ y)
y = y + 1
Next I
nom = (1 - df(UBound(df)) * x ^ (t - UBound(df)))
denom = Application.WorksheetFunction.Sum(df) + Application.WorksheetFunction.Sum(discount)
CFR = nom / denim
End Function
you should really use Option Explicit:
Option Explicit
Public Function CFR(df(), x As Double, t As Integer) As Double
Dim i As Long, y As Integer
Dim discount() As Double
Dim nom, denom As Double
ReDim discount(t) As Double
y = 1
For i = UBound(df, 1) + 1 To t
discount(i) = df(UBound(df, 1)) * (x ^ y)
y = y + 1
Next i
nom = (1 - df(UBound(df)) * x ^ (t - UBound(df)))
denom = Application.WorksheetFunction.Sum(df) + Application.WorksheetFunction.Sum(discount)
CFR = nom / denom
End Function
The issues were
1) denim instad of denom
which the use of Option Explicit would found you out immediatley
2) Dim discount()
Since VBA assumes implicit Variant type for all not explicitly declared variables, and that makes it collidw with subsequent ReDim discount(t) As Double since the Redim() statement cannot change the type of the array
3) point 2 explanation is relevant for a minor issue (not blocking the code in this case):
Dim i, y As Integer
is actually read as:
Dim i As Variant, y As Integer
If you want i to be of integer type you have to code:
Dim i As Integer, y As Integer
Related
I was trying to make sense of ByVal and ByRef and passing arguments from long to double using the ByVal keyword.
I noticed that VBA gave me the incorrect answer for the value of y squared. It does work when y (i in my sub) is a whole number.
In the below example I had i = 22.5.
The spreadsheet gave me 506.25.
My function gave me 484.
I thought both long and double support decimals.
Sub automation_test()
Dim i As Long
Dim j As Long
Dim x As Long
Dim ans As Long
i = Range("B1")
j = Range("B2")
x = Range("B3")
ans = my_model(i, j, x)
Range("B4").Value = ans
End Sub
Function my_model(ByVal y As Double, ByVal m As Double, ByVal q As Double) As Double
' my_model = (y ^ 2) * (m ^ 3) * (q ^ 1 / 2)
my_model = y ^ 2
End Function
You must declare all used variables As Double (or As Single, depending on the maximum value to be used).
Long variables do not accept decimals.
The difference is exactly the one coming from rounding (down):
22.5^2 = 506.25
22^2 = 484
Take a look at the following code. What my problem is is that I can't figure out how to redimension the n integer and the b integer. What I'm doing is the array sent1 is already working and it is populated with about 4 sentences. I need to go through each sentence and work on it but I'm having trouble.
dim sent1()
dim sent2()
dim n as integer, b as integer, x as integer
dim temp_sent as string
b = 0
For n = 1 to ubound(sent1)
temp_sent = sent1(n)
for x = 1 to len(temp_sent1)
code
if a then
b = b + 1
'**THIS IS THE PART OF THE CODE THAT IS NOT WORKING**
redim preserve sent2(1 to ubound(sent1), b)
sent2(n,b) = [code]
next
next
There are two issues in your code:
When you Dim an array without specifying the lower bound it will by default be 0 based (unless you have specified Option Base 1). When explicitly specified, lower bound can be any number, not just 0 or 1
For a multi dimensioned array, Redim Preserve can only change the last dimension, and then only the upper bound.
In general, I find it better to always specify Lower and Upper bounds, eg
Redim MyArray(1 to 10, 0 to 99)
Is there any specific reason why you want to / must use arrays?
If not, I'd suggest using collections instead. You can also have nested collections, e.g.
Dim dimension1 As New Collection
Dim dimension2 AS New Collection
dimension1.Add dimension2
etc.
That way, you won't have to worry about increasing dimensions manually at all. If you need to convert it back to a 2D Array, you can do sth like this in the end
Dim item AS Variant
Dim subCollection AS Collection
Dim nRows AS Integer
Dim nCols AS integer
' assuming "col" is your jagged collection
nRows = col.Count
For Each item in col
If TypeOf item is Collection
Set subCollection = item
If subCollection.Count > nCols Then
nCols = subCollection.Count
End If
Next item
Next item
Dim result(nRows, NCols) As Variant
' Now loop through the collections again and fill the result array
The problem that you have is that you cannot change the rank (dimensions) of an array with a redim statement.
dim sent() creates a 1-rank array, redim sent2(x, y) assumes a 2-rank array. Try dim sent(,).
Also, it will improve performance (and code robustness) if you use
dim sent1() as string
dim sent2(,) as string
In case anyone has this problem here is how I solved it:
<code>
Function find_sentences_complex(instring As String) As Variant
Dim xorr As String: xorr = ChrW(&H22BB)
Dim triple_bar As String: triple_bar = ChrW(&H2261)
Dim idisj As String: idisj = ChrW(&H2228)
Dim cond As String: cond = ChrW(&H2192)
Dim x As Integer, y As Integer, z As Integer, b As Integer
Dim total As Integer, paren_closure As Integer, marker As Boolean
Dim n As Integer
Dim sent1() As Variant, sent3() As Variant
'Dim final1d As Integer, final2d As Integer
Dim b_arr() As Integer
Dim b_max As Integer
Dim temp_string As String
For x = InStr(instring, "(") To Len(instring) Step 1
temp_string = Mid(instring, x, 1)
If Mid(instring, x, 1) = "(" Then
If marker = False Then
z = x
marker = True
End If
total = total + 1
ElseIf Mid(instring, x, 1) = ")" Then
total = total - 1
If total = 0 Then
marker = False
b = b + 1
paren_closure = x
ReDim Preserve sent1(b)
sent1(b) = Mid(instring, z, (x - z) + 1)
End If
End If
Next
Dim temp_sent1 As String
total = 0
marker = False
b = 0
Dim sent2()
ReDim sent2(UBound(sent1), 5)
For n = 1 To UBound(sent1)
temp_sent1 = sent1(n)
temp_sent1 = Mid(temp_sent1, 2, Len(temp_sent1) - 2)
b = 0
For x = 1 To Len(temp_sent1)
temp_string = Mid(instring, x, 1)
If Mid(temp_sent1, x, 1) = "(" Then
If marker = False Then
z = x
marker = True
End If
total = total + 1
ElseIf Mid(temp_sent1, x, 1) = ")" Then
total = total - 1
If total = 0 Then
marker = False
b = b + 1
paren_closure = x
'ReDim Preserve sent2(n, b)
sent2(n, b) = Mid(temp_sent1, z, (x - z) + 1)
End If
End If
Next
'this part of the code redimensions the side of the array
ReDim Preserve b_arr(n)
b_arr(n) = b
Next
b_max = MaxValOfIntArray(b_arr)
ReDim Preserve sent2(UBound(sent1), b_max)
End Function
Public Function MaxValOfIntArray(ByRef TheArray As Variant) As Integer
'This function gives max value of int array without sorting an array
Dim i As Integer
Dim MaxIntegersIndex As Integer
MaxIntegersIndex = 0
For i = 1 To UBound(TheArray)
If TheArray(i) > TheArray(MaxIntegersIndex) Then
MaxIntegersIndex = i
End If
Next
'index of max value is MaxValOfIntArray
MaxValOfIntArray = TheArray(MaxIntegersIndex)
End Function
</code>
Take a look at the following code. What my problem is is that I can't figure out how to redimension the n integer and the b integer. What I'm doing is the array sent1 is already working and it is populated with about 4 sentences. I need to go through each sentence and work on it but I'm having trouble.
dim sent1()
dim sent2()
dim n as integer, b as integer, x as integer
dim temp_sent as string
b = 0
For n = 1 to ubound(sent1)
temp_sent = sent1(n)
for x = 1 to len(temp_sent1)
code
if a then
b = b + 1
'**THIS IS THE PART OF THE CODE THAT IS NOT WORKING**
redim preserve sent2(1 to ubound(sent1), b)
sent2(n,b) = [code]
next
next
There are two issues in your code:
When you Dim an array without specifying the lower bound it will by default be 0 based (unless you have specified Option Base 1). When explicitly specified, lower bound can be any number, not just 0 or 1
For a multi dimensioned array, Redim Preserve can only change the last dimension, and then only the upper bound.
In general, I find it better to always specify Lower and Upper bounds, eg
Redim MyArray(1 to 10, 0 to 99)
Is there any specific reason why you want to / must use arrays?
If not, I'd suggest using collections instead. You can also have nested collections, e.g.
Dim dimension1 As New Collection
Dim dimension2 AS New Collection
dimension1.Add dimension2
etc.
That way, you won't have to worry about increasing dimensions manually at all. If you need to convert it back to a 2D Array, you can do sth like this in the end
Dim item AS Variant
Dim subCollection AS Collection
Dim nRows AS Integer
Dim nCols AS integer
' assuming "col" is your jagged collection
nRows = col.Count
For Each item in col
If TypeOf item is Collection
Set subCollection = item
If subCollection.Count > nCols Then
nCols = subCollection.Count
End If
Next item
Next item
Dim result(nRows, NCols) As Variant
' Now loop through the collections again and fill the result array
The problem that you have is that you cannot change the rank (dimensions) of an array with a redim statement.
dim sent() creates a 1-rank array, redim sent2(x, y) assumes a 2-rank array. Try dim sent(,).
Also, it will improve performance (and code robustness) if you use
dim sent1() as string
dim sent2(,) as string
In case anyone has this problem here is how I solved it:
<code>
Function find_sentences_complex(instring As String) As Variant
Dim xorr As String: xorr = ChrW(&H22BB)
Dim triple_bar As String: triple_bar = ChrW(&H2261)
Dim idisj As String: idisj = ChrW(&H2228)
Dim cond As String: cond = ChrW(&H2192)
Dim x As Integer, y As Integer, z As Integer, b As Integer
Dim total As Integer, paren_closure As Integer, marker As Boolean
Dim n As Integer
Dim sent1() As Variant, sent3() As Variant
'Dim final1d As Integer, final2d As Integer
Dim b_arr() As Integer
Dim b_max As Integer
Dim temp_string As String
For x = InStr(instring, "(") To Len(instring) Step 1
temp_string = Mid(instring, x, 1)
If Mid(instring, x, 1) = "(" Then
If marker = False Then
z = x
marker = True
End If
total = total + 1
ElseIf Mid(instring, x, 1) = ")" Then
total = total - 1
If total = 0 Then
marker = False
b = b + 1
paren_closure = x
ReDim Preserve sent1(b)
sent1(b) = Mid(instring, z, (x - z) + 1)
End If
End If
Next
Dim temp_sent1 As String
total = 0
marker = False
b = 0
Dim sent2()
ReDim sent2(UBound(sent1), 5)
For n = 1 To UBound(sent1)
temp_sent1 = sent1(n)
temp_sent1 = Mid(temp_sent1, 2, Len(temp_sent1) - 2)
b = 0
For x = 1 To Len(temp_sent1)
temp_string = Mid(instring, x, 1)
If Mid(temp_sent1, x, 1) = "(" Then
If marker = False Then
z = x
marker = True
End If
total = total + 1
ElseIf Mid(temp_sent1, x, 1) = ")" Then
total = total - 1
If total = 0 Then
marker = False
b = b + 1
paren_closure = x
'ReDim Preserve sent2(n, b)
sent2(n, b) = Mid(temp_sent1, z, (x - z) + 1)
End If
End If
Next
'this part of the code redimensions the side of the array
ReDim Preserve b_arr(n)
b_arr(n) = b
Next
b_max = MaxValOfIntArray(b_arr)
ReDim Preserve sent2(UBound(sent1), b_max)
End Function
Public Function MaxValOfIntArray(ByRef TheArray As Variant) As Integer
'This function gives max value of int array without sorting an array
Dim i As Integer
Dim MaxIntegersIndex As Integer
MaxIntegersIndex = 0
For i = 1 To UBound(TheArray)
If TheArray(i) > TheArray(MaxIntegersIndex) Then
MaxIntegersIndex = i
End If
Next
'index of max value is MaxValOfIntArray
MaxValOfIntArray = TheArray(MaxIntegersIndex)
End Function
</code>
I am lookin for a solution to find cubic roots in Excel. I found the below code at this website.
http://www.mrexcel.com/forum/excel-questions/88804-solving-equations-excel.html
unfortunately, it doesn't work for me - I get #VALUE! when I run it and since I am only learning VBA, I have not had luck debugging it.
Sub QUBIC(P As Double, Q As Double, R As Double, ROOT() As Double)
' Q U B I C - Solves a cubic equation of the form:
' y^3 + Py^2 + Qy + R = 0 for real roots.
' Inputs:
' P,Q,R Coefficients of polynomial.
' Outputs:
' ROOT 3-vector containing only real roots.
' NROOTS The number of roots found. The real roots
' found will be in the first elements of ROOT.
' Method: Closed form employing trigonometric and Cardan
' methods as appropriate.
' Note: To translate and equation of the form:
' O'y^3 + P'y^2 + Q'y + R' = 0 into the form above,
' simply divide thru by O', i.e. P = P'/O', Q = Q'/O',
' etc.
Dim Z(3) As Double
Dim p2 As Double
Dim RMS As Double
Dim A As Double
Dim B As Double
Dim nRoots As Integer
Dim DISCR As Double
Dim t1 As Double
Dim t2 As Double
Dim RATIO As Double
Dim SUM As Double
Dim DIF As Double
Dim AD3 As Double
Dim E0 As Double
Dim CPhi As Double
Dim PhiD3 As Double
Dim PD3 As Double
Const DEG120 = 2.09439510239319
Const Tolerance = 0.00001
Const Tol2 = 1E-20
' ... Translate equation into the form Z^3 + aZ + b = 0
p2 = P ^ 2
A = Q - p2 / 3
B = P * (2 * p2 - 9 * Q) / 27 + R
RMS = Sqr(A ^ 2 + B ^ 2)
If RMS < Tol2 Then
' ... Three equal roots
nRoots = 3
ReDim ROOT(0 To nRoots)
For i = 1 To 3
ROOT(i) = -P / 3
Next i
Exit Sub
End If
DISCR = (A / 3) ^ 3 + (B / 2) ^ 2
If DISCR > 0 Then
t1 = -B / 2
t2 = Sqr(DISCR)
If t1 = 0 Then
RATIO = 1
Else
RATIO = t2 / t1
End If
If Abs(RATIO) < Tolerance Then
' ... Three real roots, two (2 and 3) equal.
nRoots = 3
Z(1) = 2 * QBRT(t1)
Z(2) = QBRT(-t1)
Z(3) = Z(2)
Else
' ... One real root, two complex. Solve using Cardan formula.
nRoots = 1
SUM = t1 + t2
DIF = t1 - t2
Z(1) = QBRT(SUM) + QBRT(DIF)
End If
Else
' ... Three real unequal roots. Solve using trigonometric method.
nRoots = 3
AD3 = A / 3#
E0 = 2# * Sqr(-AD3)
CPhi = -B / (2# * Sqr(-AD3 ^ 3))
PhiD3 = Acos(CPhi) / 3#
Z(1) = E0 * Cos(PhiD3)
Z(2) = E0 * Cos(PhiD3 + DEG120)
Z(3) = E0 * Cos(PhiD3 - DEG120)
End If
' ... Now translate back to roots of original equation
PD3 = P / 3
ReDim ROOT(0 To nRoots)
For i = 1 To nRoots
ROOT(i) = Z(i) - PD3
Next i
End Sub
Function QBRT(X As Double) As Double
' Signed cube root function. Used by Qubic procedure.
QBRT = Abs(X) ^ (1 / 3) * Sgn(X)
End Function
Can anyone please guide me on how to fix it, so I can run it. Thanks.
EDIT: This is how I am running it in Excel (I changed Qubic to be a function instead of sub)
cells A1:A3 contain p,q, r respectively
cells B1:B3 contain Roots()
cells C1:C3 contain array for the output of Qubic
A1:1
A2:1
A3:1
B1:0.1
B2:0.1
B3:0.1
C1:
C2:
C3:
{=QUBIC(A1,A2,A3,B1:B3)}
ADD: now that it works with the fix from #assylias, I am trying the following from another sheet:
Function ParamAlpha(p,q,r) as Double
Dim p as Double
Dim q as Double
Dim r as Double
p=-5
q=-2
r=24
Dim Alpha as Double
Dim AlphaVector() as Double
AlphaVector=QubicFunction(p,q,r)
Alpha=FindMinPositiveValue(AlphaVector)
End Function
Function FindMinPositiveValue(AlphaVector) As Double
Dim N As Integer, i As Integer
N = AlphaVector.Cells.Count
Dim Alpha() As Double
ReDim Alpha(N) As Double
For i = 1 To N
If AlphaVector(i) > 0 Then
Alpha(i) = AlphaVector(i)
Else
Alpha(i) = 100000000000#
End If
Next i
FindMinPositiveValue = Application.Min(Alpha)
End Function
In Excel, I call =ParamAlpha(-5,-2,24) and it returns #VALUE!
If you add the following procedure, it will show the results in a message box. You can then modify it to do something else as you require:
Public Sub test()
Dim p As Double
Dim q As Double
Dim r As Double
Dim roots() As Double
p = 1
q = 1
r = 1
QUBIC p, q, r, roots
Dim i As Long
Dim result As String
result = "("
For i = LBound(roots, 1) To UBound(roots, 1)
result = result & roots(i) & ","
Next i
result = Left(result, Len(result) - 1) & ")"
MsgBox "Roots of y^3 + " & p & ".y^2 + " & r & ".y + " & r & " = 0 has the following roots: " & result
End Sub
Alternatively, if you want the result in the form of a fomula array directly in a spreadsheet, you can add the following function in the same module:
Public Function QubicFunction(p As Double, q As Double, r As Double) As Double()
Dim roots() As Double
QUBIC p, q, r, roots
QubicFunction = roots
End Function
You then call it from Excel by selecting a few cells (horizontally, for example A1:B1) and press CTRL+SHIFT+ENTER:
=QubicFunction(1, 1, 1)
I am trying to do some prime factorisation with my VBA excel and I am hitting the limit of the long data type -
Runtime Error 6 Overflow
Is there any way to get around this and still stay within VBA? I am aware that the obvious one would be to use another more appropriate programming language.
Lance's solution works in so far that I am able to get the big numbers into the variables now. However, when I try to apply the MOD function - bignumber MOD 2, for example - it still fails with error message
Runtime Error 6 Overflow
You can use Decimal data type. Quick hint from google: http://www.ozgrid.com/VBA/convert-to-decimal.htm
This is my Decimals.cls (VB6):
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Decimals"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'local variable(s) to hold property value(s)
Private mvarDec As Variant 'local copy
Public Property Let Dec(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Dec = 5
mvarDec = CDec(vData)
End Property
Public Property Get Dec() As Variant
Attribute Dec.VB_UserMemId = 0
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Dec
Dec = CDec(mvarDec)
End Property
and this is a testing program. The class has been setup so that you don't have to qualify with .Dec() on get and let.
Dim dec1 As New Std.Decimals
Dim dec2 As New Std.Decimals
Dim dec3 As New Std.Decimals
Dim modulus As New Std.Decimals
Sub main()
dec1 = "1000.000000001"
dec2 = "1000.00000000000001"
dec3 = dec1 + dec2
Debug.Print dec1
Debug.Print dec2
Debug.Print dec3
Debug.Print dec3 * dec3
Debug.Print dec3 / 10
Debug.Print dec3 / 100
Debug.Print Sqr(dec3)
modulus = dec1 - Int(dec1 / dec2) * dec2
Debug.Print modulus
End Sub
and sample run
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999
Here is my "big multiply" routine for multiplying arbitrarily large numbers (eg 100 characters long). It works by splitting the input numbers, which are strings, into chunks of 7 digits (because then it can cross multiply them and store the results in Doubles).
eg bigmultiply("1934567803945969696433","4483838382211678") = 8674289372323895422678848864807544574
Function BigMultiply(ByVal s1 As String, ByVal s2 As String) As String
Dim x As Long
x = 7
Dim n1 As Long, n2 As Long, n As Long
n1 = Int(Len(s1) / x + 0.999999)
n2 = Int(Len(s2) / x + 0.999999)
n = n1 + n2
Dim i As Long, j As Long
ReDim za1(n1) As Double
i = Len(s1) Mod x
If i = 0 Then i = x
za1(1) = Left(s1, i)
i = i + 1
For j = 2 To n1
za1(j) = Mid(s1, i, x)
i = i + x
Next j
ReDim za2(n2) As Double
i = Len(s2) Mod x
If i = 0 Then i = x
za2(1) = Left(s2, i)
i = i + 1
For j = 2 To n2
za2(j) = Mid(s2, i, x)
i = i + x
Next j
ReDim z(n) As Double
Dim u1 As Long, u2 As Long
Dim e As String
e = String(x, "0")
For u1 = 1 To n1
i = u1
For u2 = 1 To n2
i = i + 1
z(i) = z(i) + za1(u1) * za2(u2)
Next u2
Next u1
Dim s As String, y As Double, w As Double, m As Long
m = n * x
s = String(m, "0")
y = 10 ^ x
For i = n To 1 Step -1
w = Int(z(i) / y)
Mid(s, i * x - x + 1, x) = Format(z(i) - w * y, e)
z(i - 1) = z(i - 1) + w
Next i
'truncate leading zeros
For i = 1 To m
If Mid$(s, i, 1) <> "0" Then Exit For
Next i
If i > m Then
BigMultiply = ""
Else
BigMultiply = Mid$(s, i)
End If
End Function
MOD is trying to convert your DECIMAL type to LONG before operating on it. You may need to write your own MOD function for the DECIMAL type. You might try this:
r = A - Int(A / B) * B
where A & B are DECIMAL subtype of VARIANT variables, and r might have to be that large also (depending on your needs), though I only tested on a long.