返回列表 上一主題 發帖

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

本帖最後由 ML089 於 2021-10-23 16:43 編輯

'一元二次方程式:X2+2X-4=0 ,
'用公式解x=(-b±√b^2-4ac)/2a的方式,
'可以求出X1=1.23606797749979 X2=-3.2360679774997

'記得30年前初學Fortran語言時,練習過 牛頓XX解法,約3~5步就可以求出近似解,網路上找一下很多。
'現在電腦計算能力太強了,可以很暴力直接由 -10000 計算到 10000,以f(x)、f(x+s)兩數值誤差在小數12位數時作為近似解。
'循環次數約20000範圍+500~800收斂步驟就可以求得
x1        x2        f(x1)
近似解:-3.2360679774998 ,  誤差值4.17443857259059E-14               
近似解:1.23606797749978 , 誤差值3.73034936274053E-14               
循環次數:20612               
計算時間:0.156               


Function f(x)
    f = x ^ 2 + 2 * x - 4
End Function
Sub 一元方程式暴力解法_ML089()
    Dim r, c1, c2, n, x, x2, s, ss, ct, tm
    tm = Timer
    '[A:C].Clear
    Sheets.Add.Name = Format(Now(), "dd_hhmmss")
    x = -10000: x2 = 10000 '查詢區間
    s = 1: ss = 100        'Step 初始值及細分除數
   
    r = 3: c1 = 1: c2 = 2 'cells 位置
    Cells(r, c1).Resize(, 3) = Array("x1", "x2", "f(x1)")
    While x <= x2
        ct = ct + 1
        If Application.Median(f(x), 0, f(x + s)) = 0 Then
            r = r + 1
            Cells(r, c1).Resize(, 3) = Array(x, x + s, f(x)) 'Debug 用
            If Round(f(x), 12) = 0 Then
                r = r + 1
                Cells(r, c1) = "近似解:" & x & " , " & f(x)
                x = x + s
                s = 1
            Else
                s = s / ss
            End If
        Else
            x = x + s
        End If
    Wend
    Cells(r + 1, c1) = "循環次數:" & ct
    Cells(r + 2, c1) = "計算時間:" & Format(Timer - tm, "0.000")
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

本帖最後由 ML089 於 2021-10-23 16:50 編輯

在補充一下樓上的程式概念
01 由 -10000 至 10000 STEP s
02  當 f(x)、f(x + s)的值在 0 的左右之時
03   檢查小數12位數以內是否為 0,
      是:就是近似解之一,重新設 s=1後再重新02查詢下一個近似解
      否:設 s = s/100,再重新02步驟

x1        x2        f(x1)
-4        -3        4 (第1次0在f(-4)與f(-3)之間,s=1)
-3.24        -3.23        0.0176 (第2次0在f(-3.24)與f(-3.23)之間,s=1/100)
-3.2361        -3.236        0.00014321 (第3次0在f(-3.2361)與f(-3.231)之間,s=1/10000)
-3.236068        -3.236067        1.00624E-07
-3.23606798        -3.23606797        1.11813E-08
-3.236067978        -3.236067977        9.56568E-13
-3.236067978        -3.236067977        9.56568E-13
-3.236067977        -3.236067977        4.17444E-14
近似解:-3.2360679774998 , 4.17443857259059E-14               
0.763932023        1.763932023        -1.88854382
1.233932023        1.243932023        -0.009547719
1.236032023        1.236132023        -0.000160794
1.236067023        1.236068023        -4.27089E-06
1.236067973        1.236067983        -2.23588E-08
1.236067977        1.236067978        -4.45365E-10
1.236067977        1.236067978        -2.5846E-12
1.236067977        1.236067977        -3.73035E-14
近似解:1.23606797749978 , -3.73034936274053E-14               
循環次數:20612               
計算時間:0.168
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

回復 7# Andy2483

土木系計算機程式才會教Fortran
VBA也是在論壇看你及其他高手的答題慢慢學習來的,感謝你的踴躍答題學習不少。
重點是在活化自己的腦筋避免老年痴呆症(也不知有沒有效?)
平常日都回答函數公式,假日有空才能練習一些VBA,畢竟VBA也不是太熟。
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

回復 9# Andy2483

由USER輸入方程式,具有實用性價值寫得很好,程式計算速度很快更精準,讚。
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

本帖最後由 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

        靜思自在 : 每天無所事事,是人生的消費者,積極、有用才是人生的創造者。
返回列表 上一主題