Finding the x intercept of a 4th degree polynomial using small increments

[Mofasa777]

I am trying to find the x intercept of a 4th degree function by incrementing the x value. I feel like this way doesnt work always and isnt the most efficient way to do this, is there another way I am missing?


My code is:

  Sub Findintercept()
        Dim equation As Double, x As Double, A As Double, B As Double, C As Double, D As Double, E As Double
        A = 0.000200878
        B = -0.002203704
        C = 0.0086
        D = -0.02333
        E = 0.02033
        x = 0
        equation = A * x ^ 4 + B * x ^ 3 + C * x ^ 2 + D * x + E
        While (equation > 0.00001 Or equation < -0.00001)
            If (x > 5) Then
                MsgBox "Could not find intercept"
                equation = 0
            Else
                x = x + 0.0001
                equation = A * x ^ 4 + B * x ^ 3 + C * x ^ 2 + D * x + E
            End If
        Wend
        MsgBox x
    End Sub

Sometimes it fails to find the intercept hence the IF condition in the while loop. (Im always expecting the intercept to be less than 5!

 

[StephenCrump]

If you want to use a VBA approach like this, then rather than plodding through in tiny increments, you should be zeroing in more quickly. For example:

- f(0) is positive and f(5) is negative so test the midpoint f(2.5).
- f(0) is positive and f(2.5) is negative so test f(1.25)
- f(1.25) is positive and f(2.5) is negative so test f(1.875) etc etc

Or, more directly, you could use Excel's Solver (which you can call from VBA) to find the value of x (x<5 and x>0) for which f(x) = 0

--> y approx 1.3258770278

By the way, there is a general formula (quite complicated, but easy enough to code) you can use to find all four roots of any quartic.

Tushar Mehta has an add-in here, but doesn't provide his code: Solve Polynomials

I have just downloaded this for the first time and it seems to work well. It shows that your equation has another real root at approx 6.895614782, and also calculates the two complex roots.

 

[Mofasa777]

If you want to use a VBA approach like this, then rather than plodding through in tiny increments, you should be zeroing in more quickly. For example:

- f(0) is positive and f(5) is negative so test the midpoint f(2.5).
- f(0) is positive and f(2.5) is negative so test f(1.25)
- f(1.25) is positive and f(2.5) is negative so test f(1.875) etc etc

Or, more directly, you could use Excel's Solver (which you can call from VBA) to find the value of x (x<5 and x>0) for which f(x) = 0

--> y approx 1.3258770278

By the way, there is a general formula (quite complicated, but easy enough to code) you can use to find all four roots of any quartic.

Tushar Mehta has an add-in here, but doesn't provide his code: Solve Polynomials

I have just downloaded this for the first time and it seems to work well. It shows that your equation has another real root at approx 6.895614782, and also calculates the two complex roots.

Is there a way to incorporate the excel solver into vba code? I am going to have to find the intercepts for alot of 4th degree polynomial and need to automate it? I understand the idea of what you are saying but I still think it would be time consuming? Is there an efficient way? Or these are the only methods available?

 

[StephenCrump]

Here's a complete solution for quartics with open source code: https://newtonexcelbach.wordpress.com/2010/08/04/solving-cubic-and-quartic-equations-with-excel/

You can use the macro recorder to set up Solver. It looks to me as if Solver hones in on a correct solution if you constrain it to minimum and maximum values (as you have done here with 0 and 5), but the accuracy of the result is a little bit fuzzy depending on the starting guess.

Here's how I have modified your code to make it faster:

Sub MySolver()

    Dim a As Double, b As Double, c As Double, d As Double, e As Double
    Dim dMin As Double, dMax As Double, dCalc As Double, dTemp(-1 To 0) As Double
    Dim dTolerance As Double, dTest As Double
    Dim i As Long, lMaxIterations As Long
    
    dTolerance = 10 ^ -18
    lMaxIterations = 100   'safety catch for loop
    a = 0.000200878
    b = -0.002203704
    c = 0.0086
    d = -0.02333
    e = 0.02033
    dMin = 0
    dMax = 5
    
    'No checking!!  Assumes f(dMin) and f(dMax) have opposite signs
    dCalc = Polynomial(dMin, a, b, c, d, e)
    dTemp(dCalc > 0) = dMin
    dTemp(dCalc < 0) = dMax
    
    For i = 1 To lMaxIterations
        dTest = (dTemp(-1) + dTemp(0)) / 2
        dCalc = Polynomial(dTest, a, b, c, d, e)
        If Abs(dCalc) < dTolerance Or Abs(dTemp(-1) - dTemp(0)) <= 10 ^ -15 Then
            Exit For
        Else
            dTemp(dCalc > 0) = dTest
        End If
    Next i
    
    If i = lMaxIterations + 1 Then
        MsgBox "No solution found!"
    Else
        MsgBox "Solution: " & dTest & vbNewLine & i & " iterations"
    End If
    
End Sub
Function Polynomial(x As Double, ParamArray Coefficients()) As Double
    
    Dim i As Long
    Dim dTemp As Double
    
    For i = LBound(Coefficients) To UBound(Coefficients)
        dTemp = dTemp + Coefficients(i) * x ^ (UBound(Coefficients) - i)
    Next i
    
    Polynomial = dTemp
    
End Function

The code still relies on the user providing appropriate minimum and maximum start values. It will find an intermediate root almost instantly, but unlike the complete solution, won't specify if this is a single, double, triple or quadruplicate root. Nor will it identify multiple roots in the given interval - there could be one or three.