PRB: Rate Function Gives Error If It Can't Calculate Accurately (138536)

WORKAROUND

If the error occurs, retry the Rate function with a different initial guess value. Sometimes a different guess will lead to numerical convergence within the 20 iterations allowed.

You might want to set up an error handler that progressively changes the guess and retries the Rate function. If the Rate function continues to fail for all the guess values tried, then it may be necessary to warn the user that an accurate calculation of the rate based on the values for Total Payment, Number of Payments, and Present Value is not possible.

The following code implements an error handler to arrive at a Rate value.

Add the following code to the Form_Click event to include the error handler, and a new static variable Newguess, which is adjusted each time an error handler is called:

   Private Sub Form_Click
   Dim Fmt As Variant, FVal As Variant, Guess As Variant, PVal As Variant,_
   TotPmts As Variant, Payment As Variant, PayType As Variant, _
   APR As Variant

   Static NewGuess
   NewGuess = 0.02

   Const ENDPERIOD = 0, BEGINPERIOD = 1    ' When payments are made.
   Const MB_YESNO = 4  ' Define Yes/No buttons.
   Const ID_NO = 7 ' Define No as a response.

   On Error GoTo Errhandler

   Fmt = "##0.00"  ' Define percentage format.
   FVal = 0    ' Usually 0 for a loan.
   Guess = 0.1 ' Guess of 10 percent.
   PVal = 81709.07    '
   Payment = 720.45
   TotPmts = 700
   PayType = BEGINPERIOD
   APR = (Rate(TotPmts, -Payment, PVal, FVal, PayType, Guess) * 12) * 100
   MsgBox "Your interest rate is " & Format(CInt(APR), Fmt) & "percent."

   Exit Sub

Errhandler:

   NewGuess = NewGuess + 0.01

   If (NewGuess > 1#) Then
     MsgBox "Calculation of rate not possible-please change Total payments"
     Exit Sub
   End If

   Guess = NewGuess
   Resume

   End Sub