Public Function AccessXIRR(Domain As String, PaymentField As String, DateField As String, PK_Field As String, PK_Value As Variant, Optional PK_IsText As Boolean = False, Optional GuessRate As Double = 0.1) As Variant
On Error GoTo errlbl
'Assumes you have a table or query with a field for the Payee, the Payment, and the date paid.
Dim Payments() As Currency
Dim Dates() As Date
Dim rs As dao.Recordset
Dim strSql As String
Dim i As Integer
Dim HasInvestment As Boolean
Dim HasPayment As Boolean
Dim SumOfPayments
If PK_IsText Then PK_Value = "'" & PK_Value & "'"
strSql = "SELECT " & PaymentField & ", " & DateField & " FROM " & Domain & " WHERE " & PK_Field & " = " & PK_Value & " ORDER BY " & DateField
'Debug.Print strSql
Set rs = CurrentDb.OpenRecordset(strSql)
'Fill Payments and dates
ReDim Payments(rs.RecordCount - 1)
ReDim Dates(rs.RecordCount - 1)
Do While Not rs.EOF
If IsNumeric(rs.Fields(PaymentField).Value) Then
Payments(i) = rs.Fields(PaymentField).Value
If Payments(i) > 0 Then HasPayment = True
If Payments(i) < 0 Then HasInvestment = True
Else
AccessXIRR = "Invalid Payment Value"
Exit Function
End If
If IsDate(rs.Fields(DateField).Value) Then
Dates(i) = rs.Fields(DateField).Value
Else
AccessXIRR = "Invalid Date"
Exit Function
End If
i = i + 1
rs.MoveNext
Loop
If Not HasInvestment Then
AccessXIRR = "All Positive Cash Flows"
ElseIf Not HasPayment Then
AccessXIRR = "All Negative Cash Flows"
Else
'Choose which function to calculate XIRR
'A function to do a binomial search and get a good guess. Somewhere
'between one and -1 and 1 where the sign changes.
GuessRate = GetGoodGuess(Payments, Dates)
Debug.Print "Guess " & GuessRate & vbCrLf
AccessXIRR = MyXIRR(Payments, Dates, GuessRate)
End If
Exit Function
errlbl:
If Err.Number = 3078 Then
MsgBox "Can not find your table or query " & vbCrLf & strSql
ElseIf Err.Number = 3061 Then
MsgBox Err.Number & " " & Err.Description & vbCrLf & "Sql: " & strSql
End If
End Function
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
