0

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!

4

1 に答える 1

2

次のプロシージャを追加すると、メッセージ ボックスに結果が表示されます。その後、必要に応じて別のことを行うように変更できます。

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

次に、Excel からいくつかのセル (A1:B1 など、水平に) を選択して呼び出し、CTRL + SHIFT + ENTER を押します。

=QubicFunction(1, 1, 1)
于 2012-11-19T16:21:53.863 に答える