问题描述
我正在寻找在Excel中查找立方根的解决方案.我在此网站上找到了以下代码.
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
不幸的是,它对我不起作用-我得到了#VALUE!当我运行它时,由于我只是在学习VBA,因此我没有运气来调试它.
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.
这就是我在Excel中运行它的方式(我将Qubic更改为函数而不是子函数)单元格A1:A3分别包含p,q,r单元格B1:B3包含Roots()单元格C1:C3包含用于Qubic输出的数组
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 respectivelycells B1:B3 contain Roots()cells C1:C3 contain array for the output of Qubic
A1:1A2:1A3:1
A1:1A2:1A3:1
B1:0.1B2:0.1B3:0.1
B1:0.1B2:0.1B3:0.1
C1:C2:C3:{= QUBIC(A1,A2,A3,B1:B3)}
C1:C2:C3:{=QUBIC(A1,A2,A3,B1:B3)}
添加:现在它可以使用@assylias中的修复程序,我正在另一张纸上尝试以下操作:
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
在Excel中,我调用= ParamAlpha(-5,-2,24),它返回 #VALUE!
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
或者,如果您希望直接在电子表格中以fomula数组的形式显示结果,则可以在同一模块中添加以下函数:
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
然后通过选择一些单元格(水平地,例如A1:B1)从Excel中调用它,然后按CTRL + SHIFT + ENTER:
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)
这篇关于使用vba的立方根的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!