使用vba的立方根

Question

我正在尋找一種解決方案來在Excel中查找立方根。我在這個網站找到了下面的代碼。

http://www.mrexcel.com/forum/excel-questions/88804-solving-equations-excel.html

不幸的是，它並沒有爲我工作 - 我得到#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 

任何人都可以請指導我如何解決它，所以我可以運行它。謝謝。

編輯：這是我如何在Excel中運行它（I改變Qubic是一個函數，而不是子） 單元格A1：A3分別含有P，Q，R 細胞B1：B3包含羅茨（） 細胞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!

Answer 1

如果添加了以下過程中，它會顯示在消息框中的結果。然後，您可以修改它做其它的事情，你需要：

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陣列中的電子表格的形式，你可以在同一模塊中添加以下功能：

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鍵：

=QubicFunction(1, 1, 1)