Public Function MyXIRR(Payments() As Currency, Dates() As Date, Optional GuessRate As Double = 0.1) As Variant
On Error GoTo errlbl
Const Tolerance = 0.0001
'Like the Excel it only searches 100 times. Not sure why 100, but you could change this
'Based on a faulty guess you can get into a loop where you cannot converge
Const MaxIterations = 1000
Dim NPV As Double
Dim DerivativeOfNPV As Double
Dim ResultRate As Double
Dim NewRate As Double
Dim i As Integer
'Since we are trying to find the Rate that makes the NPV = 0 we are finding the roots of the equation
'Since there is no closed form to do this, you can use Newtons method
'x_(n+1) = x_n - f(x_n)/f'(x_n)
'Basically you evaluate the function and take the tangent at that point. Your next x is where the tangent crosses
'The X axis. Each time this gets you closer and closer to the real root. Can be shown graphically
ResultRate = GuessRate
MyXIRR = "Not Found"
For i = 1 To MaxIterations
NPV = NetPresentValue(Payments, Dates, ResultRate)
DerivativeOfNPV = DerivativeOfNetPresentValue(Payments, Dates, ResultRate)
NewRate = ResultRate - NPV / DerivativeOfNPV
ResultRate = NewRate
' Debug.Print "NPV " & NPV & " NPVprime " & DerivativeOfNPV & " NewRate " & NewRate
If Abs(NPV) < Tolerance Then
MyXIRR = NewRate
Debug.Print "Solution found in " & i & " iterations. Rate = " & NewRate & vbCrLf
Exit Function
End If
Next i
Exit Function
errlbl:
Debug.Print Err.Number & " " & Err.Description & " NPV " & NPV & " dNPV " & DerivativeOfNPV
End Function
Public Function NetPresentValue(Payments() As Currency, Dates() As Date, Rate As Double) As Double
Dim TimeInvested As Double
Dim i As Integer
Dim InitialDate As Date
InitialDate = Dates(0)
'Debug.Print "NPV rate " & Rate
For i = 0 To UBound(Payments)
TimeInvested = (Dates(i) - Dates(0)) / 365
NetPresentValue = NetPresentValue + Payments(i) / ((1 + Rate) ^ TimeInvested)
Next i
End Function
Public Function DerivativeOfNetPresentValue(Payments() As Currency, Dates() As Date, Rate As Double) As Double
Dim TimeInvested As Double
Dim i As Integer
Dim InitialDate As Date
Dim NPVprime As Double
InitialDate = Dates(0)
'NPV = P/(1+R)^N
'where P is the payment, R is rate, N is the time invested
'The derivative with respect to R is
'DerivateNPV = -NP/(1+R)^(N+1)
'And the derivative of a sum is the sum of the derivatives
'Debug.Print Rate & "Derive NPV rate"
For i = 0 To UBound(Payments)
TimeInvested = (Dates(i) - Dates(0)) / 365
NPVprime = NPVprime - TimeInvested * Payments(i) / ((1 + Rate) ^ (TimeInvested + 1))
Next i
DerivativeOfNetPresentValue = NPVprime
End Function
Public Function GetGoodGuess(Payments() As Currency, Dates() As Date) As Double
Dim TimeInvested As Double
Dim NPV As Double
Dim i As Double
Dim Rate As Double
Dim InitialDate As Date
Dim newNPV As Double
Dim minNPV As Double
Dim minRate As Double
Dim UpperRate As Double
Dim LowerRate As Double
Dim UpperNPV As Double
Dim LowerNPV As Double
Const iterations = 10
InitialDate = Dates(0)
'check Left end
LowerRate = -0.999
LowerNPV = NetPresentValue(Payments, Dates, LowerRate) ' this is NPV associated with lower rate. Should be the larger NPV
'Check right end
UpperRate = 0.999
UpperNPV = NetPresentValue(Payments, Dates, UpperRate)
'Debug.Print "LowerNPV " & LowerNPV & " UpperNPV " & UpperNPV
' Debug.Print "LowerRate " & LowerRate & "UpperRate " & UpperRate
'If no sign change between the two then the rate is either > .999 or <-.999
If Not HasSignChange(LowerNPV, UpperNPV) Then
If Abs(LowerNPV) < Abs(UpperNPV) Then
Rate = LowerRate
Else
Rate = UpperRate
End If
GetGoodGuess = Rate
Exit Function
End If
Rate = 0
For i = 1 To iterations 'number binomial searches
newNPV = NetPresentValue(Payments, Dates, Rate)
'Debug.Print "UpperRate " & UpperRate & " lowerRate " & LowerRate
'Debug.Print "New Rate " & Rate
If HasSignChange(LowerNPV, newNPV) Then
UpperNPV = newNPV
UpperRate = Rate
Else
LowerNPV = newNPV
LowerRate = Rate
End If
Rate = GetMidRate(LowerRate, UpperRate)
'Debug.Print " UpperRate " & UpperRate & " lowerRate " & LowerRate & " midRate " & Rate & vbCrLf
Next i
GetGoodGuess = Rate
End Function
Public Function GetMidRate(SmallerRate As Double, LargerRate As Double) As Double
GetMidRate = (LargerRate - SmallerRate) / 2 + SmallerRate
End Function
Public Function HasSignChange(NPV1 As Double, NPV2 As Double) As Boolean
If (NPV1 > 0 And NPV2 < 0) Or (NPV1 < 0 And NPV2 > 0) Then HasSignChange = True
End Function
