Board logo

標題: EXCEL VBA求一元二次方程式 (不用公式解)(2) [打印本頁]
作者: 森野    時間: 2021-10-20 11:00     標題: EXCEL VBA求一元二次方程式 (不用公式解)(2)

本帖最後由 森野 於 2021-10-20 11:01 編輯

因為小學生不能再EXCEL程式區板回復 首先感謝Andy2483回應 但我看程式碼裡面也有公式在裡面  可能是我描述不清楚 我重新描述一次
用excel vba 求解一元二次方程式X²+2X-4=0 不能用帶入公式的方式(因為如果更高次也許就沒有公式可以帶入)，附件有詳細說明

結論
1.x1、x2代入多少，判定正確方向，錯誤就停止
2.上述找出正確方向，逼近解，最終找出解答
想知道如何設定程式碼以及詳細
[attach]34245[/attach]
作者: Andy2483    時間: 2021-10-20 14:20

本帖最後由 Andy2483 於 2021-10-20 14:32 編輯

回復 1# 森野


參考
Option Explicit
Sub TEST()
Dim X, Y, a, b, c, n, U1, U2, u, v, S, S0, S1, Y0, Y1, X1, X2, P, J
J = 1: Y = a * X ^ n + b * X + c: a = 1: b = 2: c = -4: n = 2
If n = 2 Then
   If (4 * a * c - b ^ 2) / 4 * a = 0 Then
      MsgBox "唯一解 X= " & (-b) / (2 * a): Exit Sub
      ElseIf ((4 * a * c - b ^ 2) / 4 * a > 0 And a > 0) Or ((4 * a * c - b ^ 2) / 4 * a < 0 And a < 0) Then
         MsgBox " X 無解!": Exit Sub
   End If
   If b = 0 And c < 0 Then X1 = (-c / a) ^ 0.5: X2 = -(-c / a) ^ 0.5
End If
888: S0 = -100 * J: S1 = 100 * J: S = J: P = 1
999
For X = S0 To S1 Step S
   Y0 = a * X ^ n + b * X + c
   Y1 = (a * (X + S)) ^ n + (b * (X + S)) + c
   P = Y0 * Y1
   If (S < 10 ^ -13 And J = 1) Or (S > -(10 ^ -13) And J = -1) Then P = 0
   If P = 0 Then
      If c = 0 And J = 1 Then X1 = X
      If c = 0 And J = -1 Then X2 = X
      If J = -1 Then: MsgBox "X1= " & X1 & vbLf & vbLf & "X2= " & X2: Exit Sub
      J = -1: GoTo 888
      ElseIf P < 0 Then
         S0 = X: S1 = S0 + S: S = S / 10  '
         If J = 1 Then
            MsgBox "X1 介於 " & S0 & " ~ " & S1
            X1 = S1
            Else
               MsgBox "X2 介於 " & S0 & " ~ " & S1
               X2 = S1
         End If
         GoTo 999
   End If
Next
End Sub
End Sub
作者: 森野    時間: 2021-10-20 16:28

回復 2# Andy2483

前輩您好  可以稍微簡單說明一下每項代表的意義嗎
這串以下好像是公式 設定這串的用意是什麼 (4 * a * c - b ^ 2) / 4 * a = 0  (如果不能用公式解是否可以不設定此項)
If n = 2 Then  
   If (4 * a * c - b ^ 2) / 4 * a = 0 Then
      MsgBox "唯一解 X= " & (-b) / (2 * a): Exit Sub
      ElseIf ((4 * a * c - b ^ 2) / 4 * a > 0 And a > 0) Or ((4 * a * c - b ^ 2) / 4 * a < 0 And a < 0) Then
         MsgBox " X 無解!": Exit Sub
請前輩稍微說明一下
888 和999和 S0及S0 =-100*J和S1和 S1 =100*J 是什麼
還有以下的設定說明 想了解詳細
End If
888: S0 = -100 * J: S1 = 100 * J: S = J: P = 1  
999
For X = S0 To S1 Step S
   Y0 = a * X ^ n + b * X + c
   Y1 = (a * (X + S)) ^ n + (b * (X + S)) + c
   P = Y0 * Y1
   If (S < 10 ^ -13 And J = 1) Or (S > -(10 ^ -13) And J = -1) Then P = 0
   If P = 0 Then
      If c = 0 And J = 1 Then X1 = X
      If c = 0 And J = -1 Then X2 = X
      If J = -1 Then: MsgBox "X1= " & X1 & vbLf & vbLf & "X2= " & X2: Exit Sub
      J = -1: GoTo 888
      ElseIf P < 0 Then
         S0 = X: S1 = S0 + S: S = S / 10  '
         If J = 1 Then
            MsgBox "X1 介於 " & S0 & " ~ " & S1
            X1 = S1
            Else
               MsgBox "X2 介於 " & S0 & " ~ " & S1
               X2 = S1
         End If
         GoTo 999
   End If
Next
End Sub
上述程式跑出來
X1=1.2360679774997，X2=-3.2360679774997
答案後面好像還少一項數字
X1=1.23606797749979，X2=-3.23606797749979
程式應該要怎麼改
感謝前輩
作者: Andy2483    時間: 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
作者: ML089    時間: 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
作者: ML089    時間: 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
作者: Andy2483    時間: 2021-10-23 17:05

回復 6# ML089


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

回復 7# Andy2483

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

回復 9# Andy2483

由USER輸入方程式，具有實用性價值寫得很好，程式計算速度很快更精準，讚。
作者: ML089    時間: 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
作者: Andy2483    時間: 2022-9-28 22:01

回復 11# ML089


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)