立方根使用vba
我正在寻找一个解决scheme，以在Excel中find立方根。 我在这个网站find了下面的代码。
http://www.mrexcel.com/forum/excel-questions/88804-solving-equations-excel.html
不幸的是，它不适合我 – 我得到#VALUE！ 当我运行它，因为我只学习VBA，我没有运气debugging它。
Sub QUBIC(P As Double, Q As Double, R As Double, ROOT() As Double) ' QUBIC - 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', ie 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 任何人都可以请指导我如何解决它，所以我可以运行它。 谢谢。
编辑：这是我如何在Excel中运行它（我改变了Qubic是一个函数，而不是子）单元格A1：A3分别包含p，q，r单元格B1：B3包含Roots（）单元格C1：C3包含数组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：现在，它与@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
在Excel中，我调用= ParamAlpha（-5，-2,24），并返回#VALUE!
如果添加以下过程，则会在消息框中显示结果。 你可以修改它来做其他的事情
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
或者，如果希望以电子表格的forms直接在结果中显示结果数组，可以在同一模块中添加以下函数：
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
然后通过select几个单元格（水平，例如A1：B1），然后按CTRL + SHIFT + ENTER从Excel中调用它：
=QubicFunction(1, 1, 1)