返回列表 上一主題 發帖

EXCEL VBA求一元二次方程式 (不用公式解)(2)

本帖最後由 ML089 於 2021-10-26 08:40 編輯

回復 9# Andy2483
星期日去露營,星期一晚上回家,看到你的程式解一元四次,套到我原先的程式沒有辦法完成解出,不完善地方很多。
本來露營回來很累應要早睡的卻又睡不著,重新修正一下原先程式,終於完成可以睡覺了。
1 大區間 -10000 ~ 10000 查詢要快,將 查詢 Step 分為 大、中、小(可變) ,初始 s = 100,遇到第一解後 改為 s = s1 = 0.1,當解在區間(x ~ x+s)時再細分 s/ss,ss=10都可以。加速查詢
   解答完4次解就可以跳離迴圈,加速查詢
  這次優化計算迴圈由 20800次降至 500次左右
2 有近似解時,再以f( round(x,12) )檢查修正為真實解。
3 還缺少你的友善人機介面,這星期再來想一想。

Function f(x)
    'f = x ^ 2 + 2 * x - 4
    'f = x ^ 4 - 6 * x ^ 3 + x ^ 2 + 2 * x + 24
    f = 2 * x ^ 4 - 4 * x ^ 3 - 3 * x ^ 2 + 7 * x - 2  '人工填入方程式
End Function
Sub 一元方程式暴力解法_ML089()
    Dim r, c1, c2, n, x, x2, s, s1, ss, ct, tm, xNo, xN
    tm = Timer
    ThisWorkbook.Sheets.Add(After:=Worksheets(1)).Name = Format(Now(), "dd_hhmmss") '
    x1 = -10000: x2 = 10000: x = x1 '查詢區間
    s = 100: s1 = 0.1: ss = 10:  'Step 初始值使用s,找解1區間後使用s1,ss區間細分除數
    xNo = 4: xN = 0 '一元幾次 : 計次
   
    r = 3: c1 = 1: c2 = 2 'cells 位置
    'Cells(r, c1).Resize(, 3) = Array("x1", "x2", "f(x1)")
    While x <= x2
        'DoEvents '會增加計算時間
        ct = ct + 1 '循環次數
        If Application.Median(f(x), 0, f(x + s)) = 0 Then '解答是否在x與x+s之間
            'r = r + 1: Cells(r, c1).Resize(, 3) = Array(x, x + s, f(x)) 'Debug 用
            If Round(f(x), 12) = 0 Then '精度小數12位數為0時為近似解
                xN = xN + 1: r = r + 1
                ANS = "近似解:X" & xN & " = "
                If f(Round(x, 12)) = 0 Then '真實解判斷與修正
                    x = Round(x, 12)
                    ANS = "真實解:X" & xN & " = "
                End If
                Cells(r, c1) = ANS & x & " ,f(x) = " & f(x)
                If xN = xNo Then GoTo 999 '解答完成跳出迴圈
                x = x + s
                s = s1
            Else
                s = s / ss '目前x~x+s區間,s再細分1/SS倍
            End If
        Else
            x = x + s
        End If
    Wend
999:
    Cells(r + 1, c1) = "查詢區間:" & x1 & "    " & x2
    Cells(r + 2, c1) = "Step 初始值及細分除數:" & s1 & "    " & ss
    Cells(r + 3, c1) = "循環次數:" & ct
    Cells(r + 4, c1) = "計算時間:" & Format(Timer - tm, "0.000")
End Sub

'可以刪除日測試工作表
Sub Del_Sheet()
    Dim MyBook As Workbook, sh As Worksheet
    Set MyBook = ThisWorkbook
    Application.DisplayAlerts = False  '停止系統的警示
    For Each sh In MyBook.Sheets
        If sh.Name Like Day(Now()) & "_*" Then sh.Delete '刪除當日 DD_*
    Next
    Application.DisplayAlerts = True   '恢復系統的警示
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 是非當教育,讚美作警惕。
返回列表 上一主題