Thread: LOOPING: Faster rate of convergence required

I am developing a UDF which requires some looping to arrive at the result. To keep it simple, part of the routine is akin to solving the following Amount equation for i.

Find i such that A=1.72846 given A=(1+i)^10

The following code resolves to the correct answer of i = 5.6248%

Code:

Sub nn()
Time1 = Timer
i = 0.01
k = 1
Do
A = (1 + i) ^ 10
i = i + 0.0000001
k = k + 1
'Debug.Print k & "........" & i
Loop Until Application.Round(A, 4) = 1.7285
MsgBox i & " ... " & Timer - Time1
End Sub

But it does so using 462,477 iterations and taking a whooping 90 seconds! (One would expect under 100 iterations to be ideal).

While Solver can easily tackle this problem, the Solver tool cannot be deployed in my exercise. Solver requires a WorkSheet interface and is hence inappropriate for incorporation in the UDF.

Can someone kindly come up with a non-linear algorithm that will speed up the rate of convergence? I would be happy with a solution that takes under 5 seconds.

If A = (i +1)^10

then LN(A)=10*LN(i+1)

i+1 = e ^ (LN(A)/10)

i = (e ^ (LN(A)/10)) -1

Code:

Dim a as Double
Dim i as Double

a = 1.72846

i = Exp(Log(a) / 10) - 1

returns 0.0562480820384001 with no loops.

The spreadsheet function =EXP(LN(A1)/10)-1 gives the same result.

Your binary search is nice.
I adapted it to find roots of any function. It needs some more error checking (are the intial boundries appropriate?, etc.).

The Sub test solves both the problem in the OP and finds the cube root of 3.

Code:

Sub test()
    MsgBox binarySolver("Ftn", 1.72846, 0, 3, 10 ^ -4) & " is the solution to the OPs problem."
    MsgBox binarySolver("Cube", 3, 0, 5, 10 ^ -7) & " is the cube root of 3."
End Sub

Function binarySolver(thisFunction As String, Goal As Double, Low As Double, High As Double, Accuracy As Double) As Double
Rem to solve thisFunction(x) = Goal within accuracy
Rem Low and High are estimates that bracket the solution
Dim Mid As Double
Dim FtnLow As Double, FtnMid As Double, FtnHigh As Double
Dim loopCount As Long

FtnLow = Run(thisFunction, Low)
FtnHigh = Run(thisFunction, High)
loopCount = 0
Do
    loopCount = loopCount + 1
    
    Mid = (Low + High) / 2
    
    FtnMid = Run(thisFunction, Mid)
    
    If Sgn(FtnLow - Goal) = Sgn(FtnMid - Goal) Then
        Low = Mid: FtnLow = FtnMid
    Else
        High = Mid: FtnHigh = FtnMid
    End If

Loop Until Abs(Goal - FtnMid) < Accuracy

binarySolver = Mid
'MsgBox loopCount
End Function

Function Ftn(a As Double) As Double
    Ftn = (1 + a) ^ 10
    End Function

Function Cube(a As Double) As Double
    Cube = a ^ 3
    End Function