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

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

12^#

發表於 2022-9-28 22:01 | 只看該作者

回復 11# ML089

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

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

11^#

發表於 2021-10-26 00:21 | 只看該作者

本帖最後由 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 三鍵輸入公式

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

10^#

發表於 2021-10-25 21:49 | 只看該作者

回復 9# Andy2483

由USER輸入方程式，具有實用性價值寫得很好，程式計算速度很快更精準，讚。

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

9^#

發表於 2021-10-25 08:07 | 只看該作者

回復 8# ML089

1.30年前機械系是學C語言,沒認真學!一支草一點露! 往3D Catia 鑽研到交棒,轉管理才發現管理不是罵罵人就好,一分證據說一分話才能服眾!
逆著學VBA,從錄製巨集開始學,一路沒競爭者又很雞婆到處幫同事寫堪用的巨集! 看到以前的貴人在此論壇!欣喜就進來了!

2.老年痴呆症狀有點跡象了,視力也退化了!常動腦.常段練身體,保持健康才是最重要的!共勉

3.對二次曲線有興趣,就複習了 y=ax2+bx+c ,剛好版主要收斂得到解答的方法,也是一股腦用一招半式回答!
搜尋了Median找到這網頁: https://docs.microsoft.com/zh-tw/office/vba/api/excel.worksheetfunction.median
拋磚引玉學到了很多! 謝謝! 也謝謝論壇的多元性!

4.後輩用多次曲線的概念研究了一元四次方程式的實數解法也放上來! 記錄下來! 多年以後再回頭看此帖! 應該是五味雜陳!
請有興趣的前輩們分享.指導!謝謝!

Option Explicit
Sub 一元一二三四次方程式_實數解()
Dim InB$, Q$, i&, x#, x1#, a#, a1#, a2#, b#, c#, s#, S0#, S1#, S2#, Y0#, Y1#
Dim P#, J$, T&, d&, Arr, st#, S3#, K$, K1$, K2$, Kb$, Kc$
InB = UCase(InputBox("請輸入方程式例:  X4-6X3+X2+2X+24=0", "請輸入", "2X4-4X3-3X2+7X-2=0"))
If (InB Like "*0" = False And InB Like "*#") Or InB Like "*X" Then InB = InB & "=0"
Q = InB: InB = Replace(InB, " ", "")
If InB Like "*X*=0" = False Or InB Like "*,*" Then T = -1: GoTo 777
If InB Like "X*" Then InB = "1" & InB
If InB Like "-X*" Then InB = "-1" & InB
InB = Replace(Replace(InB, "+X", "+1X"), "-X", "-1X")
InB = Replace(Replace(Replace(Replace(InB, "X4=", "X4+0="), _
   "X3=", "X3+0="), "X2=", "X2+0="), "X1=", "X1+0=")
InB = Replace(Replace(Replace(Replace(InB, "+", ",+"), "-", ",-"), "=0", ",=,"), "X", ",X")
Arr = Split(InB, ",")
If InStr(",X4,X3,X2,X,", "," & Arr(1) & ",") = 0 Then T = -3: GoTo 777
For i = 0 To UBound(Arr)
If Arr(i) = "X4" Then a2 = Arr(i - 1)
If Arr(i) = "X3" Then a1 = Arr(i - 1)
If Arr(i) = "X2" Then a = Arr(i - 1)
If Arr(i) = "X" Then b = Arr(i - 1)
If Arr(i) = "=" Then c = Arr(i - 1)
Next
K = a: K1 = a1: K2 = a2: Kb = b: Kc = c:
If K & K1 & K2 & Kb & Kc Like "*0.*" Then T = -4: GoTo 777
T = 0: d = 26: S0 = -10001: S1 = 10001: S2 = S1: s = 0.5: st = s: P = 1
999
For x = S0 To S1 Step s
DoEvents
If s = st Then S3 = x
Y0 = a2 * x ^ 4 + a1 * x ^ 3 + a * x ^ 2 + b * x + c: x1 = x + s
Y1 = a2 * x1 ^ 4 + a1 * x1 ^ 3 + a * x1 ^ 2 + b * x1 + c
If Y0 = 0 Then
   J = J & vbLf & "實數解X = " & x: S0 = S3 + s: S1 = S2: GoTo 999
End If
If Y1 = Y0 Then S0 = x + st: S1 = S2: GoTo 999
P = Y0 * Y1
If Int(Abs(P * 10 ^ d)) = 0 Then
   T = T + 1
   If s <> st Then J = J & vbLf & "實數解X = " & x1
   s = st: S0 = S3 + s: S1 = S2: GoTo 999
End If
If Int(Abs(s * 10 ^ d)) = 0 Then P = 0
If P < 0 Then
   S0 = x: S1 = S0 + s: s = s / 10: GoTo 999
   ElseIf P > Abs(a2) + Abs(a1) + Abs(a) + Abs(b) + Abs(c) Then
      S0 = x + st: S1 = S2: GoTo 999
End If
Next
777
If T > 0 Then
MsgBox Q & vbLf & J
ElseIf T = 0 Then
   MsgBox Q & vbLf & vbLf & " X 無實數解!"
Else
   MsgBox Q & vbLf & vbLf & " 無法執行!"
End If
End Sub

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

8^#

發表於 2021-10-23 17:17 | 只看該作者

回復 7# Andy2483

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

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

7^#

發表於 2021-10-23 17:05 | 只看該作者

回復 6# ML089

前輩厲害!
前輩是資訊科系嗎?
我是機械科系,腦筋比較駑鈍,也老了才學VBA!
對前輩們非常佩服!
我們的MIS 該上這論壇來研究研究!
該用EXCEL當ERP的前台!
謝謝分享!

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

6^#

發表於 2021-10-23 16:32 | 只看該作者

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

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

x1 x2 f(x1)
-4 -3 4　(第１次０在ｆ(-4)與f(-3)之間，s=1)
-3.24 -3.23 0.0176　(第2次０在ｆ(-3.24)與f(-3.23)之間，s=1/100)
-3.2361 -3.236 0.00014321　(第3次０在ｆ(-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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

5^#

發表於 2021-10-23 16:13 | 只看該作者

本帖最後由 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 三鍵輸入公式

　暱稱: 厚臉皮的學生

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

4^#

發表於 2021-10-21 08:53 | 只看該作者

本帖最後由 Andy2483 於 2021-10-21 08:56 編輯

回復 1# 森野

Option Explicit
Sub 一元二次方程式()
'X ^ 2 + 2 * X - 4 = 0 有兩解
Dim X, S, S0, S1, Y0, Y1, X1, X2, P
S0 = -1000
S1 = 1000
S = 1
'↑設定變數初值
888
'↓開始迴圈(-1000 到 1000 間隔1)
For X = S0 To S1 Step S
Y0 = X ^ 2 + 2 * X - 4
Y1 = (X + S) ^ 2 + 2 * (X + S) - 4
P = Y0 * Y1
'↓運用二次函數在Y值=0前的負數與Y值=0後的正數乘積是負數
If P < 0 Then
   S0 = X '重新給S0設定值
   S1 = S0 + S '重新給S1設定值
   S = S / 10  '重新給S設定值
   MsgBox "X1 介於 " & S0 & " ~ " & S1
   X1 = S1
   GoTo 888 '結束迴圈,跳到 888 位置繼續執行
End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''
S0 = 1000
S1 = -1000
S = -1
'↑重設變數初值
999
'↓開始迴圈(1000 到 -1000 間隔-1)
For X = S0 To S1 Step S
Y0 = X ^ 2 + 2 * X - 4
Y1 = (X + S) ^ 2 + 2 * (X + S) - 4
P = Y0 * Y1
If P < 0 Then
   S0 = X
   S1 = S0 + S
   S = S / 10
   MsgBox "X2 介於 " & S0 & " ~ " & S1
   X2 = S1
   GoTo 999
End If
Next
MsgBox "X1= " & X1 & vbLf & vbLf & "X2= " & X2
End Sub

Sub 一元二次方程式整數解1()
Dim X
For X = -1000 To 1000 Step 1
If X ^ 2 - 4 = 0 Then MsgBox "X = " & X
Next
End Sub

Sub 一元二次方程式整數解2()
'1奈米（nm）= 10 埃（A）= 10^-9m
'電腦要RUN 2000*10^9次判斷,EXCEL會感覺當掉
Dim X
For X = -1000 To 1000 Step 10 ^ -9
If X ^ 2 - 4 = 0 Then MsgBox "X = " & X
Next
End Sub