使用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 中运行它的方式（我将 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)}

添加：现在它与 @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

或者，如果您希望直接在电子表格中以公式数组的形式获得结果，您可以在同一模块中添加以下函数：

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)