EXCEL VBA求一元二次方程式 (不用公式解)(2)
- 帖子
- 2025
- 主題
- 13
- 精華
- 0
- 積分
- 2053
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- Office2007
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台北市
- 註冊時間
- 2011-3-2
- 最後登錄
- 2024-3-14
     
|
本帖最後由 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 三鍵輸入公式
|
|
|
|
|
- 帖子
- 2025
- 主題
- 13
- 精華
- 0
- 積分
- 2053
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- Office2007
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台北市
- 註冊時間
- 2011-3-2
- 最後登錄
- 2024-3-14
     
|
本帖最後由 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 三鍵輸入公式
|
|
|
|
|
- 帖子
- 2025
- 主題
- 13
- 精華
- 0
- 積分
- 2053
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- Office2007
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台北市
- 註冊時間
- 2011-3-2
- 最後登錄
- 2024-3-14
     
|
回復 7# Andy2483
土木系計算機程式才會教Fortran
VBA也是在論壇看你及其他高手的答題慢慢學習來的,感謝你的踴躍答題學習不少。
重點是在活化自己的腦筋避免老年痴呆症(也不知有沒有效?)
平常日都回答函數公式,假日有空才能練習一些VBA,畢竟VBA也不是太熟。 |
|
|
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式
|
|
|
|
|
- 帖子
- 2025
- 主題
- 13
- 精華
- 0
- 積分
- 2053
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- Office2007
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台北市
- 註冊時間
- 2011-3-2
- 最後登錄
- 2024-3-14
     
|
回復 9# Andy2483
由USER輸入方程式,具有實用性價值寫得很好,程式計算速度很快更精準,讚。 |
|
|
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式
|
|
|
|
|
- 帖子
- 2025
- 主題
- 13
- 精華
- 0
- 積分
- 2053
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- Office2007
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台北市
- 註冊時間
- 2011-3-2
- 最後登錄
- 2024-3-14
     
|
本帖最後由 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 三鍵輸入公式
|
|
|
|
|