I'm writing a VBA function which I need in my Excel spreadsheet, this is the code I wrote:
Function costo(x As Variant, d1 As Double, p1 As Double)
Dim d As Variant
d = Array(Array(129, 90), Array(129, 98), Array(142, 81), Array(133, 98), _
Array(139, 102), Array(156, 144), Array(125, 127), Array(137, 222), _
Array(213, 241), Array(145, 229), Array(206, 118), Array(152, 167))
Dim c As Double
c = 0
Dim i As Long
For i = 1 To 12
c = c + 50 * x(i) * distanza(d1, p1, d(i)(0), d(i)(1))
Next i
costo = c
End Function
Function distanza(ByVal d1 As Double, ByVal p1 As Double, ByVal d2 As Double, ByVal p2 As Double) As Double
Dim r As Double
r = 6371
distanza = 2 * r * WorksheetFunction.Asin(Sqr(WorksheetFunction.Power(Sin((d1 - d2) / 2), 2) + _
Cos(d1) * Cos(d2) * WorksheetFunction.Power(Sin((p1 - p2) / 2), 2)))
End Function
x are 12 cells of my spreadsheet, while d1 and p1 are two cell.
When I run the code in debug, the variable costo have the correct value, but in my spreedsheet I get #VALUE!.
Any suggestion?
Try to add error handler on error go to, exit function and messagebox. I got same #VALUE but i dunno what numbers you adding. My error says subcript out of range. Numbers too high.
Function costo(x As Variant, d1 As Double, p1 As Double)
On Error GoTo MY_ERROR
Dim d As Variant
d = Array(Array(129, 90), Array(129, 98), Array(142, 81), Array(133, 98), _
Array(139, 102), Array(156, 144), Array(125, 127), Array(137, 222), _
Array(213, 241), Array(145, 229), Array(206, 118), Array(152, 167))
Dim c As Double
c = 0
Dim i As Long
For i = 1 To 12
c = c + 50 * x(i) * distanza(d1, p1, d(i)(0), d(i)(1))
Next i
costo = c
Exit Function
MY_ERROR:
MsgBox Err.Description
End Function
The bug in your code causing the premature exit occurs because d is a 12-element variant array with Lbound = 0 and Ubound = 11. So when you refer to the array elements in your c= line, when i reaches 12 you will have an out-of-bounds subscript error.
Change that line to:
c = c + 50 * x(i) * distanza(d1, p1, d(i - 1)(0), d(i - 1)(1))
and your code should run.
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
I was wondering whether someone would be able to help me out with a problem I am having with a printing function in excel VBA. I am trying to print out the outputs of an ODE using RK4, and I would like to know how to loop a printvalue function, so that every loop an increase in the cell value occurs.
Also wondering why the line PrintValues (x.ToString()) is saying that the x is an invalid qualifier? If there are any other mistakes you feel are in the code, please let me know, although I am fairly certain everything works fine Any help would be greatly appreciated :)
Option Explicit
Public Function RK_KCTest() 'ByVal rateConst As Double, ByVal equilConst As Double, ByVal initConc As Double, ByVal epsilon As Double, ByVal initFlow As Double, ByVal dv As Double, ByVal xi As Double, ByVal vi As Double, ByVal vf As Double, ByVal vout As Double) As Double
'NOTE: This is the ultimate function, that will essentially take all the function's calculations below it, and accumate them into a matrix which it will then print to the user, displaying the results
Dim rateConst As Double
rateConst = GetValue("F9")
Dim equilConst As Double
equilConst = GetValue("F7")
Dim initConc As Double
initConc = GetValue("F5")
Dim epsilon As Double
epsilon = GetValue("F8")
Dim initFlow As Double
initFlow = GetValue("F6")
Dim dv As Double
dv = GetValue("F11")
Dim xi As Double
xi = GetValue("F12")
Dim vi As Double
vi = GetValue("F10")
Dim vf As Double
vf = GetValue("F13")
Dim vout As Double
vout = GetValue("F15")
Dim i As Integer
i = 0
Dim m As Integer
m = 0
Dim x As Double
x = xi
Dim v As Double
v = vi
Dim vCutoff
Dim dx As Double
dx = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx)
Dim h As Double
h = 50
Dim hi As Double
hi = h
Dim xnew As Double
Dim xerror As Double
Dim hNext As Double
Dim xScaled As Double
Do 'Loop for the calculation of RK4, calling up the subfunction for each iteration, until the difference between the the final value of v and the value before it is less than that of the stepsize
vCutoff = v + vout
h = dv 'h which is the step size is equal to the change of v, basically just another term for stepsize'
If (vCutoff - v < h) Then h = vCutoff - v 'This is basically a trimmming step, this is used if the increment exceeds the solution determining v value (If the program calculates past the point needed)
If (vCutoff > vf) Then vCutoff = vf
Call RK_KC(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx, h, dv, xnew, xerror) 'calls the RK4 values calculated in the subfunction, incorparating them into the loop, and declaring the new value of x, so the next iteration is able to start
x = xnew
PrintValue ("x")
Range("a5").Select
PrintValues (x.ToString())
If (v >= vf) Then Exit Do 'If the volume is greater than or equal to the cutoff volume then the program will exit the loop and the final values or solutions can be determined
Loop
End Function
Public Function RK_KC(ByRef x As Double, ByRef v As Double, ByVal rateConst As Double, ByVal equilConst As Double, ByVal initConc As Double, ByVal epsilon As Double, ByVal initFlow As Double, ByRef dx As Double, ByRef h As Double, ByRef dv As Double, ByVal xnew As Double, ByVal xerror As Double)
'NOTE: This function is called by the Integrator subfunction, and the calculations in this function are implemented into a loop
'so therefore iterations for every value of x and vnew are computed, and the subfunctions calling the integrator function will display the results in an excel spreadsheet
'Implementing the RKF_KC method into the main function by defining the six k values, as well as the temp values of x calculated between each stored value of k2,k3,k4,k5,k6
Dim k1 As Double, k2 As Double, k3 As Double, k4 As Double, k5 As Double, k6 As Double
Dim xTemp As Double 'Called xTemp because it is a placeholder
Dim a2, a3, a4, a5, a6 As Double
a2 = 0.2
a3 = 0.3
a4 = 0.6
a5 = 1
a6 = 0.875
'The parameters of A column in the butcher table for Cash-Karp RKF method
Dim b21, b31, b32, b41, b42, b43, b51, b52, b53, b54, b61, b62, b63, b64, b65 As Double
b21 = 0.2
b31 = 3 / 40
b32 = 9 / 40
b41 = 0.3
b42 = -0.9
b43 = 1.2
b51 = -11 / 54
b52 = 2.5
b53 = -70 / 27
b54 = 35 / 27
b61 = 1631 / 55296
b62 = 175 / 512
b63 = 575 / 13824
b64 = 44275 / 110592
b65 = 253 / 4096
'The parameters of B matrix in the butcher table for Cash-Karp RKF method
Dim c1, c3, c4, c6 As Double
c1 = 37 / 378
c3 = 250 / 621
c4 = 125 / 594
c6 = 512 / 1771
'The parameters of C row in the butcher table for Cash-Karp RKF method
Dim dc1, dc3, dc4, dc5, dc6 As Double 'The parameters of the differences of between the fourth and fifth order Cash-Karp RKF methods
dc1 = c1 - (2825 / 27648)
dc3 = c3 - (18575 / 48384)
dc4 = c4 - (13525 / 55296)
dc5 = -277 / 14336
dc6 = c6 - 0.25
'The parameters of the differences of between the fourth and fifth order Cash-Karp RKF methods, also known as the local truncation error
xTemp = x + b21 * h * dx 'Calculates the temporary value of x between v;x and v+h;xnew based on k1
x = xTemp
v = v + a2 * h
k2 = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx) 'Calls the derivative function and calculates the value of k2 using the stepsize, "a" parameters, and the temporary value of x
xTemp = x + h * (b31 * dx + b32 * k2) 'Calculates the temporary value of x between v;x and v+h;xnew based on k2
x = xTemp
v = v + a3 * h
k3 = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx) 'Calls the derivative function and calculates the value of k3 using the stepsize, "b" parameters, and the temporary value of x
xTemp = x + h * (b41 * dx + b42 * k2 + b43 * k3) 'Calculates the temporary value of x between v;x and v+h;xnew based on k3
x = xTemp
v = v + a4 * h
k4 = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx) 'Calls the derivative function and calculates the value of k4 using the stepsize, "b" parameters, and the temporary value of x
xTemp = x + h * (b51 * dx + b52 * k2 + b53 * k3 + b54 * k4) 'Calculates the temporary value of x between v;x and v+h;xnew based on k4
x = xTemp
v = v + a5 * h
k5 = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx) 'Calls the derivative function and calculates the value of k5 using the stepsize, "b" parameters, and the temporary value of x
xTemp = x + h * (b61 * dx + b62 * k2 + b63 * k3 + b64 * k4 + b65 * k5) 'Calculates the temporary value of x between v;x and v+h;xnew based on k5
x = xTemp
v = v + a6 * h
k6 = Derivatives(x, v, rateConst, equilConst, initConc, epsilon, initFlow, dx) 'Calls the derivative function and calculates the value of k6 using the stepsize, "b" parameters, and the temporary value of x
xnew = x + h * (c1 * dx + c3 * k3 + c4 * k4 + c6 * k6) 'The new value of x based on the Cash-Karp RKF butcher table
xerror = h * (dc1 * dx + dc3 * k3 + dc4 * k4 + dc5 * k5 + dc6 * k6) 'the error value of x associated with Cash-Karp RKF
End Function
Public Function Derivatives(ByRef x As Double, ByVal v As Double, ByVal rateConst As Double, ByVal equilConst As Double, ByVal initConc As Double, ByVal epsilon As Double, ByVal initFlow As Double, ByRef dx As Double)
'NOTE: This function is called by the RK4 subfunction to calculate k values
'Defined ODE, which is the change of conversion (dx) over the change of volume(dv). Within this ODE there are constant values of
'Initial flowrate, Initial Concentration, the epsilon value, the equilibrium constant. the reaction rate constant, and finally the value of conversion which is x
dx = ((rateConst * initConc) / (initFlow)) * ((((1 - x) / (1 + (epsilon * x))) - ((4 * initConc * x ^ (2)) / (equilConst * (1 + (epsilon * x)) ^ (2)))))
End Function
Public Function GetValue(cellToGet As String) As Double
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Dim returnVal As Double
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
ws.Unprotect
Set TxtRng = ws.Range(cellToGet)
returnVal = CDbl(val(TxtRng.Value))
GetValue = returnVal
Exit Function
End Function
Public Function PrintValue(str As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
ws.Unprotect
Set TxtRng = ws.Range("A5")
TxtRng.Value = str
End Function
Here is an example of using Cash-Karp with a different diff eq.
Option Explicit
Const PI As Double = 3.14159265358979
Public Function CalcSlope(ByVal x As Double, ByVal y As Double) As Double
CalcSlope = Cos(PI * x) / Sqr(1 + y ^ 2)
End Function
Public Function CASHKARP_1(ByVal h As Double, ByVal x0 As Double, ByVal y0 As Double, ByRef y_err) As Double
Dim K1 As Double, K2 As Double, K3 As Double, K4 As Double, _
K5 As Double, K6 As Double
K1 = h * CalcSlope( _
x0, _
y0)
K2 = h * CalcSlope( _
h * (1# / 5#) + x0, _
K1 * (1# / 5#) + y0)
K3 = h * CalcSlope( _
h * (3# / 10#) + x0, _
K1 * (3# / 40#) + K2 * (9# / 40#) + y0)
K4 = h * CalcSlope( _
h * (3# / 5#) + x0, _
K1 * (3# / 10#) + K2 * (-9# / 10#) + K3 * (6# / 5#) + y0)
K5 = h * CalcSlope( _
h * (1#) + x0, _
K1 * (-11# / 54#) + K2 * (5# / 2#) + K3 * (-70# / 27#) + K4 * (35# / 27#) + y0)
K6 = h * CalcSlope( _
h * (7# / 8#) + x0, _
K1 * (1631# / 55296#) + K2 * (175# / 512#) + K3 * (575# / 13824#) + K4 * (44275# / 110592#) + K5 * (253# / 4096#) + y0)
CASHKARP_1 = (37# / 378#) * K1 + (250# / 621#) * K3 _
+ (125# / 594#) * K4 + (512# / 1771#) * K6
y_err = (2825# / 27648# - 37# / 378#) * K1 + _
(18575# / 48384# - 250# / 621#) * K3 + _
(13525# / 55296# - 125 / 594#) * K4 + _
(277# / 14336) * K5 + (1# / 4# - 512# / 1771#) * K6
End Function
Public Sub SolveRk()
Dim count As Long
count = Range(Range("F3"), Range("F3").End(xlDown)).Rows.count
Range("F3").Resize(count, 3).ClearContents
Dim x0 As Double, y0 As Double, h0 As Double, xf As Double
x0 = Range("x0")
y0 = Range("y0")
xf = Range("xf")
h0 = Range("h0")
Dim x As Double, h As Double, y As Double, e As Double, r As Double
x = x0: h = h0: y = y0
Dim rk_results() As Variant
ReDim rk_results(1 To 10, 1 To 3)
Const tol As Double = 0.0000001
count = 1
rk_results(1, 1) = x0: rk_results(1, 2) = y: rk_results(1, 3) = h
Do
x = x0 + h
y = y0 + CASHKARP_1(h, x0, y0, e)
If Abs(e) < tol Then
count = count + 1
If UBound(rk_results, 1) < count Then
ExpandMatrix rk_results, 2 * UBound(rk_results, 1)
End If
rk_results(count, 1) = x: rk_results(count, 2) = y: rk_results(count, 3) = h
If x - xf > -tol Then Exit Do
h = h * 1.15
If x + h > xf Then
h = xf - x
End If
x0 = x: y0 = y
Else
h = h / 1.2
End If
Loop
Range("F3").Resize(count, 3).Value = rk_results
End Sub
Public Sub ExpandMatrix(ByRef values() As Variant, Optional ByVal new_rows As Long = 0, Optional ByVal new_cols As Long = 0)
If new_rows = 0 Then new_rows = UBound(values, 1)
If new_cols = 0 Then new_cols = UBound(values, 2)
Dim temp() As Variant
ReDim temp(1 To new_rows, 1 To new_cols)
Dim i As Long, j As Long
For i = 1 To UBound(values, 1)
For j = 1 To UBound(values, 2)
temp(i, j) = values(i, j)
Next j
Next i
values = temp
End Sub
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)