|
这样?
- Sub BinarySearch(ByVal Expression As String, ByVal Q1 As Double, ByVal Q2 As Double, Optional ByRef root As Double, Optional ByVal Precision As Double = 0.0000000001)
- Dim n As Long, msg As String
- msg = "方程 " & Expression & " 在区间[" & Q1 & "," & Q2 & "]"
- Expression = Replace(Expression, "=", "-")
- If Evaluate(Replace(Expression, "x", Q1)) * Evaluate(Replace(Expression, "x", Q2)) > 0 Then
- MsgBox msg & "之间没有根,请重新输入!"
- Exit Sub
- End If
- n = 0
- Do
- root = (Q1 + Q2) / 2
- If Evaluate(Replace(Expression, "x", root)) * Evaluate(Replace(Expression, "x", Q1)) > 0 Then
- Q1 = root
- Else
- Q2 = root
- End If
- n = n + 1
- If n > 200 Then Exit Do
- Loop Until Abs(Q1 - Q2) <= Precision
- MsgBox msg & "找到一个根:" & root
- End Sub
- Sub solve()
- BinarySearch "x^2=3", 1, 2
- End Sub
复制代码 |
|