vba 使用vba的立方根
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/13457212/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
cubic roots using vba
提问by user1155299
I am lookin for a solution to find cubic roots in Excel. I found the below code at this website.
我正在寻找在 Excel 中找到三次方根的解决方案。我在这个网站上找到了下面的代码。
http://www.mrexcel.com/forum/excel-questions/88804-solving-equations-excel.html
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.
不幸的是，它对我不起作用 - 我得到了 #VALUE！当我运行它时，因为我只学习 VBA，所以我没有调试它。
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
编辑：这就是我在 Excel 中运行它的方式（我将 Qubic 更改为函数而不是子）单元格 A1:A3 分别包含 p、q、r 单元格 B1:B3 包含 Roots() 单元格 C1:C3 包含数组Qubic 的输出
A1:1 A2:1 A3:1
A1:1 A2:1 A3:1
B1:0.1 B2:0.1 B3:0.1
B1:0.1 B2:0.1 B3:0.1
C1: C2: C3: {=QUBIC(A1,A2,A3,B1:B3)}
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:
添加：现在它可以与@assylias 的修复一起使用，我正在尝试从另一张表中执行以下操作：
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!
在 Excel 中，我调用 =ParamAlpha(-5,-2,24) 并返回 #VALUE!
回答by assylias
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:
然后通过选择几个单元格（水平方向，例如 A1:B1）并按 CTRL+SHIFT+ENTER 从 Excel 调用它：
=QubicFunction(1, 1, 1)
