ML089

回復 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

Andy2483

回復 11# ML089


    前輩教師節快樂
向您道歉 sorry：
10樓之後忙新的案件，好長一段時間沒上論壇學習，前幾天學習Function ()才看到11樓的前輩指導回覆，心裏一直過意不去，趁今天教師節向前輩回覆，並祝前輩 教師節快樂