This quite long -- about 10K -- because I've tried to mimic the ATP-XIRR
function WRT to accepting either ranges or literal arrays as arguments.
It does not have XIRR's limitation that the 1st date must be the earliest one,
and it ignores both blanks and text in the lists (AIR, XIRR chokes on text).
I don't think there are any lines that are more than 79 characters, but beware
of possible problems due to line-wrapping in the message.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Const MaxChange As Double = 0.00000001
Const MaxTries As Long = 100
Enum ArrayDims '07/26/2003
NotArray = 0
SingleDim = 1
Horizontal = 2
Vertical = 3
Rectangular = 0
End Enum
Function XXIRR(TransactionAmounts As Variant, TransactionDates As Variant, _
Optional Guess As Double = 0.1) As Variant
'replacement for XIRR in ATP
Dim N As Long
Dim Dates() As Double
Dim Amounts() As Double
N = PreprocessTransactions(TransactionAmounts, TransactionDates, _
Amounts(), Dates())
If N = 0 Then
XXIRR = CVErr(xlErrRef)
Else
XXIRR = DoXIRR(Amounts(), Dates(), Guess)
End If
End Function 'XXIRR
Function XXNPV(Rate As Double, TransactionAmounts As Variant, _
TransactionDates As Variant) As Variant
'replacement for XNPV in ATP
Dim N As Long
Dim Dates() As Double
Dim Amounts() As Double
If Rate <= -1 Then
XXNPV = CVErr(xlErrNum)
Else
N = PreprocessTransactions(TransactionAmounts, TransactionDates, _
Amounts(), Dates())
If N = 0 Then
XXNPV = CVErr(xlErrRef)
Else
XXNPV = DoXNPV(Rate, Amounts(), Dates())
End If
End If
End Function 'XXNPV
Private Function DoXIRR(TxnAmts() As Double, TxnDates() As Double, _
Optional Guess As Double = 0.1) As Variant
'02/23/2005
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Newton-Raphson method:
' Given PV a function of X, determine the value of X
' such that SUM[PV] = 0, using iteration.
' dPVdX = derivative of PV with respect to X
' NB: if X = 1 + Rate, dX/dRate = 1
'
' Calculate PV and dPVdX using an arbitrary initial estimate of X.
' Change X by -PV/dPVdX and calculate again.
' Repeat until X changes by less than some arbitrary small amount.
' PV of an individual cash flow = CashFlow(i) / [(1 + Rate)^(YearFrax(i))]
' = CashFlow(i) * [(1 + Rate)^(-YearFrax(i))]
' PVSum = SUM[individual cash flows]
' Let X = 1 + Rate
' Let t(i) = -YearFrax(i)
' PV(i) = CashFlow(i) * X^(t(i))
' dPVSum/dX = SUM[dPV/dX]
' dPV/dX = CashFlow(i) * t(i) * X^(t(i)- 1)
' = CashFlow(i) * t(i) * X^(t(i)) / X
' = CashFlow(i) * X^(t(i)) * t(i) / X
' = PV(i) * t(i) / X
' dPVSum/dX = 1/X * SUM[PV(i) * t(i)]
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim InitialRate As Double
Dim SignOfNetCashFlows As Long
Dim t() As Double
Dim X As Double
Dim N As Long
Dim FoundSolution As Boolean
Dim Try As Long
Dim SumPVs As Double
Dim dPVdX As Double
Dim i As Long
Dim PV As Double
Dim Delta As Double
CheckGuess TxnAmts(), Guess, InitialRate, SignOfNetCashFlows
If SignOfNetCashFlows = 0 Then
DoXIRR = 0
Exit Function
End If
'calculate -t for each transaction just once
'NB: array t() contains values of -t, not +t, so no
'need to use -t(i) when calculating PV and dPVdX
DatesToT TxnDates(), t()
X = 1 + InitialRate
N = UBound(TxnAmts)
FoundSolution = False
Try = 0
Do
SumPVs = 0
dPVdX = 0
For i = 1 To N
PV = TxnAmts(i) * (X ^ t(i))
SumPVs = SumPVs + PV
dPVdX = dPVdX + PV * t(i)
Next i
'finish calculation of derivative
dPVdX = dPVdX / X
'calculate size of change in x for next try
Delta = SumPVs / dPVdX
'check that new X will be > 0; if not,
'decrease X by 50% instead
If X - Delta <= 0 Then Delta = X / 2
If Abs(Delta) < MaxChange Then
FoundSolution = True
Else
X = X - Delta
End If
Try = Try + 1
Loop Until FoundSolution Or (Try = MaxTries)
If FoundSolution Then
X = X - 1 'X = 1 + Rate: Rate = X - 1
If Sgn(X) <> SignOfNetCashFlows Then X = -X
DoXIRR = X
Else
DoXIRR = "Could not determine rate!"
End If
End Function 'DoXIRR
Private Function DoXNPV(Rate As Double, _
TxnAmts() As Double, TxnDates() As Double) As Variant
Dim t() As Double
Dim X As Double
Dim SumPV As Double
Dim Txn As Long
DatesToT TxnDates(), t()
X = 1 + Rate
SumPV = 0
For Txn = 1 To UBound(TxnAmts)
SumPV = SumPV + TxnAmts(Txn) * (X ^ t(Txn))
Next Txn
DoXNPV = SumPV
End Function 'DoXNPV
Private Function PreprocessTransactions(OrigAmts As Variant, _
OrigDates As Variant, TxnAmts() As Double, TxnDates() As Double) As Long
'07/26/2003: modify per changes in StandardizedArray function
'move data from worksheet ranges (vertical or horizontal) or literal arrays
'to 2-dim VBA vertical arrays, then remove blanks
'return number of transactions
Dim Amt As Double
Dim Dt As Double
Dim i As Long
Dim j As Long
Dim N As Long
Dim vaTxnAmts As Variant
Dim vaTxnDates As Variant
PreprocessTransactions = 0
'a/o 7/26/2003 StandardizedArray returns vertical array
N = StandardizedArray(OrigDates, vaTxnDates, True)
i = StandardizedArray(OrigAmts, vaTxnAmts, False)
If N = 0 Or i <> N Then Exit Function
ReDim TxnDates(1 To N)
ReDim TxnAmts(1 To N)
j = 0
For i = 1 To N
Dt = Val(vaTxnDates(i, 1))
If Dt <> 0 Then
Amt = Val(vaTxnAmts(i, 1))
If Amt <> 0 Then
j = j + 1
TxnDates(j) = Dt
TxnAmts(j) = Amt
End If
End If
Next i
Select Case j
Case 0
ReDim TxnDates(0)
ReDim TxnAmts(0)
Case 1 To N - 1
ReDim Preserve TxnDates(1 To j)
ReDim Preserve TxnAmts(1 To j)
End Select
PreprocessTransactions = j
End Function 'PreprocessTransactions
Private Sub CheckGuess(Amounts() As Double, UsersGuess As Double, _
NewGuess As Double, Sign As Long)
'adjust Guess to ensure that (a) it's the same sign as the net cash flows,
'(b) is > -1, (c) is not 0;
'also returns the sign of the net cash flows
Sign = Sgn(ArraySum(Amounts()))
If Sign = 0 Then
'true rate is 0
NewGuess = 0
ElseIf UsersGuess <> 0 Then
'we're here if sign of cash flows <> 0 and guess <> 0
'ensure that guess and net cash flows have same sign
If Sgn(UsersGuess) = Sign Then
NewGuess = UsersGuess
Else
NewGuess = -UsersGuess
End If
'correct guess <= -1
If NewGuess <= -1 Then NewGuess = -1 + MaxChange * 10
Else
'we're here if sign of cash flows <> 0 and guess = 0
NewGuess = 0.1 * Sign
End If
End Sub 'CheckGuess
Private Sub DatesToT(TxnDates() As Double, TimeInterval() As Double)
Dim j As Long
Dim BaseDate As Double
Dim N As Long
'get earliest date
j = LocateMin(TxnDates())
BaseDate = TxnDates(j)
'calculate time inverval in years for each transaction
'NB: result is always <= 0
N = UBound(TxnDates(), 1)
ReDim TimeInterval(1 To N)
For j = 1 To N
TimeInterval(j) = (BaseDate - TxnDates(j)) / 365
Next j
End Sub 'DatesToT
Private Function StandardizedArray(OrigArg As Variant, _
NewArray As Variant, ConvertDates As Boolean) As Long
Dim Ary As Variant
'07/26/2003: always return a vertical array
'convert original argument (range or Variant()),
'to 2 dimension array in variant, 1-based,
'with dates converted to doubles
StandardizedArray = 0
Select Case TypeName(OrigArg)
Case "Range"
If OrigArg.Cells.Count > 1 Then
StandardizedArray = MakeTwoDimArray(OrigArg.Value2, NewArray, False)
End If
Case "Variant()"
StandardizedArray = _
MakeTwoDimArray(OrigArg, NewArray, ConvertDates)
End Select
End Function 'StandardizedArray
Private Function MakeTwoDimArray(OldArray As Variant, _
NewArray As Variant, ConvertDates As Boolean) As Long
'07/26/2003: return num rows in NewArray instead of TRUE/FALSE
'OldArray is known to be a Variant(), either a
'range used in an array formula or an array constant;
'if from a range, it's base 1, 2 dim, which is OK;
'if from a literal array, it's base 0, usually 1 dim;
'convert the latter to base 1, 2 dim
'optionally convert date data types to doubles
Dim i As Long
Dim j As Long
Dim k As Long
Dim N As Long
Dim SourceRow As Long
N = 0
Select Case ArrayShape(OldArray)
Case SingleDim
'convert to 2-dim vertical, base 1
j = LBound(OldArray)
k = UBound(OldArray)
ReDim NewArray(1 To k - j + 1, 1 To 1)
For i = j To k
N = N + 1
NewArray(N, 1) = OldArray(i)
Next i
Case Horizontal
'transpose to vertical, base 1
j = LBound(OldArray, 2)
k = UBound(OldArray, 2)
SourceRow = LBound(OldArray, 1)
ReDim NewArray(1 To j - k + 1, 1 To 1)
For i = j To k
N = N + 1
NewArray(N, 1) = OldArray(SourceRow, i)
Next i
Case Vertical
'convert to base 1 prn
j = LBound(OldArray, 1)
k = UBound(OldArray, 1)
If j = 0 Then
ReDim NewArray(1 To k - j + 1, 1 To 1)
For i = j To k
N = N + 1
NewArray(N, 1) = OldArray(i, 0)
Next i
Else
N = k
NewArray = OldArray
End If
End Select
If (N <> 0) And ConvertDates Then
For i = 1 To N
If IsDate(NewArray(i, 1)) Then
NewArray(i, 1) = CDbl(CDate(NewArray(i, 1)))
End If
Next i
End If
MakeTwoDimArray = N
End Function 'MakeTwoDimArray
Private Function ArrayShape(vaArray As Variant) As ArrayDims
'07/26/2003: use Enum for return values
Dim R As Long
Dim C As Long
'vaArray is known to be Variant(), no need to check that
R = UBound(vaArray, 1)
On Error Resume Next
C = UBound(vaArray, 2)
If Err.Number <> 0 Then
ArrayShape = SingleDim
Else
On Error GoTo 0
'it's 2-dim: check # rows and # cols
R = R - LBound(vaArray, 1) + 1
C = C - LBound(vaArray, 2) + 1
If (R = 1 And C > 1) Then
ArrayShape = Horizontal
ElseIf (R > 1 And C = 1) Then
ArrayShape = Vertical
Else
ArrayShape = Rectangular
End If
End If
End Function 'ArrayShape
Private Function ArraySum(dArray() As Double) As Double
Dim S As Double
Dim i As Long
S = 0
For i = LBound(dArray) To UBound(dArray)
S = S + dArray(i)
Next i
ArraySum = S
End Function 'ArraySum
Private Function LocateMax(dArray() As Double) As Long
Dim Lo As Long
Dim Where As Long
Dim i As Long
Lo = LBound(dArray)
Where = Lo
For i = Lo + 1 To UBound(dArray)
If dArray(i) > dArray(Where) Then Where = i
Next i
LocateMax = Where
End Function 'LocateMax
Private Function LocateMin(dArray() As Double) As Long
Dim Lo As Long
Dim Where As Long
Dim i As Long
Lo = LBound(dArray)
Where = Lo
For i = Lo + 1 To UBound(dArray)
If dArray(i) < dArray(Where) Then Where = i
Next i
LocateMin = Where
End Function 'LocateMin
