使用vba的立方根 [英] cubic roots using vba

问题描述

我正在寻找在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 respectively cells B1:B3 contain Roots() cells C1:C3 contain array for the output of Qubic

A1:1A2:1A3:1

A1:1 A2:1 A3:1

B1:0.1B2:0.1B3: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)}

添加:现在它可以使用@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的立方根的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！