Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.
' Function by Patrick Matthews
Option Explicit
Enum PaymentIntervals
pmtDaily = 0
pmtWeekly = 1
pmtBiWeekly = 2
pmtMonthly = 3
pmtQuarterly = 4
pmtSemiAnnually = 5
pmtAnnually = 6
End Enum
Function PayoffDate(FirstPayDate As Date, Interval As PaymentIntervals, BeginPrincipal As Double, _
PeriodRate As Double, Periods As Long, Optional ExtraPrin As Double = 0)
Dim SchedArr As Variant
Dim Counter As Long
SchedArr = AmortSchedTraditional(BeginPrincipal, PeriodRate, Periods, ExtraPrin)
For Counter = 1 To UBound(SchedArr, 1)
If SchedArr(Counter, 5) = 0 Then Exit For
Next
Select Case Interval
Case pmtDaily: PayoffDate = DateAdd("d", Counter - 1, FirstPayDate)
Case pmtWeekly: PayoffDate = DateAdd("ww", Counter - 1, FirstPayDate)
Case pmtBiWeekly: PayoffDate = DateAdd("ww", 2 * (Counter - 1), FirstPayDate)
Case pmtMonthly: PayoffDate = DateAdd("m", Counter - 1, FirstPayDate)
Case pmtQuarterly: PayoffDate = DateAdd("q", Counter - 1, FirstPayDate)
Case pmtSemiAnnually: PayoffDate = DateAdd("m", 6 * (Counter - 1), FirstPayDate)
Case pmtAnnually: PayoffDate = DateAdd("yyyy", Counter - 1, FirstPayDate)
End Select
End Function
Function AmortSchedTraditional(ByRef BeginPrincipal As Double, ByRef PeriodRate As Double, ByRef Periods As Long, _
Optional ByRef ExtraPrin As Double = 0)
' This function returns an array with the amortization schedule for a loan with known
' beginning principal, period rate, number of periods, and optional fixed extra principal
' with each payment. All arguments should be positive
' The function returns an array of length (1 To N, 1 To 5), where N is the number of payments
' ultimately needed to retire the loan (may be different from initial Periods argument if extra
' principal payments are made)
' In the second dimension, the values are:
' 1: Balance before payment X
' 2: Total amount of payment X
' 3: Principal amount of payment X
' 4: Interest amount of payment X
' 5: Balance after payment X
' To use this function in Excel, use an array formula. If the array area has more rows than the
' function returns, the 'extra' rows will show a #N/A error. You can use Conditional Formatting
' to dynamically hide such results.
' This function will work in other VBA and VB projects.
Dim Schedule() As Double
Dim Schedule2() As Double
Dim BeginBal As Double
Dim Counter As Long
Dim Counter2 As Long
Dim LevelPay As Double
' Dimension array with 'first pass' amortization schedule
ReDim Schedule(1 To Periods, 1 To 5) As Double
' Negative extra payments are suppressed
If ExtraPrin < 0 Then ExtraPrin = 0
BeginBal = BeginPrincipal
LevelPay = -Pmt(PeriodRate, Periods, BeginPrincipal) + ExtraPrin
For Counter = 1 To Periods
Schedule(Counter, 1) = BeginBal
' Interest is easy to determine; do it first
Schedule(Counter, 4) = BeginBal * PeriodRate
' Amount of principal portion depends in part on the remaining balance before the payment
' is applied; the principal amount can never be larger than this
Schedule(Counter, 3) = IIf((LevelPay - Schedule(Counter, 4)) < BeginBal, _
LevelPay - Schedule(Counter, 4), BeginBal)
' Total payment = principal portion + interest portion
Schedule(Counter, 2) = Schedule(Counter, 3) + Schedule(Counter, 4)
' Determine balance after payment is applied. Check for a balance approaching zero
Schedule(Counter, 5) = BeginBal - Schedule(Counter, 3)
If Schedule(Counter, 5) < 0.01 Then
Schedule(Counter, 5) = 0
Exit For
End If
BeginBal = Schedule(Counter, 5)
Next
' Create a new array that has only as many 'rows' as there are payments to be made
ReDim Schedule2(1 To Counter, 1 To 5) As Double
For Counter2 = 1 To Counter
Schedule2(Counter2, 1) = Schedule(Counter2, 1)
Schedule2(Counter2, 2) = Schedule(Counter2, 2)
Schedule2(Counter2, 3) = Schedule(Counter2, 3)
Schedule2(Counter2, 4) = Schedule(Counter2, 4)
Schedule2(Counter2, 5) = Schedule(Counter2, 5)
Next
' Assign the function return value
AmortSchedTraditional = Schedule2
End Function
' Function by Patrick Matthews
Option Explicit
Enum PaymentIntervals
pmtDaily = 0
pmtWeekly = 1
pmtBiWeekly = 2
pmtMonthly = 3
pmtSemiMonthly = 4
pmtQuarterly = 5
pmtSemiAnnually = 6
pmtAnnually = 7
End Enum
Function PayoffDate(FirstPayDate As Date, Interval As PaymentIntervals, BeginPrincipal As Double, _
PeriodRate As Double, Periods As Long, Optional ExtraPrin As Double = 0)
Dim SchedArr As Variant
Dim Counter As Long
Dim Date1 As Date
Dim Date2 As Date
SchedArr = AmortSchedTraditional(BeginPrincipal, PeriodRate, Periods, ExtraPrin)
For Counter = 1 To UBound(SchedArr, 1)
If SchedArr(Counter, 5) = 0 Then Exit For
Next
Select Case Interval
Case pmtDaily: PayoffDate = DateAdd("d", Counter - 1, FirstPayDate)
Case pmtWeekly: PayoffDate = DateAdd("ww", Counter - 1, FirstPayDate)
Case pmtBiWeekly: PayoffDate = DateAdd("ww", 2 * (Counter - 1), FirstPayDate)
Case pmtMonthly: PayoffDate = DateAdd("m", Counter - 1, FirstPayDate)
Case pmtSemiMonthly
If Counter Mod 2 = 0 Then 'even number of payments
PayoffDate = DateAdd("m", (Counter - 1) / 2, FirstPayDate)
Else
Date1 = DateAdd("m", Int((Counter - 1) / 2), FirstPayDate)
Date2 = DateAdd("m", 1, Date1)
PayoffDate = DateAdd("d", Int(DateDiff("d", Date1, Date2) / 2), Date1)
End If
Case pmtQuarterly: PayoffDate = DateAdd("q", Counter - 1, FirstPayDate)
Case pmtSemiAnnually: PayoffDate = DateAdd("m", 6 * (Counter - 1), FirstPayDate)
Case pmtAnnually: PayoffDate = DateAdd("yyyy", Counter - 1, FirstPayDate)
End Select
End Function
Function AmortSchedTraditional(ByRef BeginPrincipal As Double, ByRef PeriodRate As Double, ByRef Periods As Long, _
Optional ByRef ExtraPrin As Double = 0)
' This function returns an array with the amortization schedule for a loan with known
' beginning principal, period rate, number of periods, and optional fixed extra principal
' with each payment. All arguments should be positive
' The function returns an array of length (1 To N, 1 To 5), where N is the number of payments
' ultimately needed to retire the loan (may be different from initial Periods argument if extra
' principal payments are made)
' In the second dimension, the values are:
' 1: Balance before payment X
' 2: Total amount of payment X
' 3: Principal amount of payment X
' 4: Interest amount of payment X
' 5: Balance after payment X
' To use this function in Excel, use an array formula. If the array area has more rows than the
' function returns, the 'extra' rows will show a #N/A error. You can use Conditional Formatting
' to dynamically hide such results.
' This function will work in other VBA and VB projects.
Dim Schedule() As Double
Dim Schedule2() As Double
Dim BeginBal As Double
Dim Counter As Long
Dim Counter2 As Long
Dim LevelPay As Double
' Dimension array with 'first pass' amortization schedule
ReDim Schedule(1 To Periods, 1 To 5) As Double
' Negative extra payments are suppressed
If ExtraPrin < 0 Then ExtraPrin = 0
BeginBal = BeginPrincipal
LevelPay = -Pmt(PeriodRate, Periods, BeginPrincipal) + ExtraPrin
For Counter = 1 To Periods
Schedule(Counter, 1) = BeginBal
' Interest is easy to determine; do it first
Schedule(Counter, 4) = BeginBal * PeriodRate
' Amount of principal portion depends in part on the remaining balance before the payment
' is applied; the principal amount can never be larger than this
Schedule(Counter, 3) = IIf((LevelPay - Schedule(Counter, 4)) < BeginBal, _
LevelPay - Schedule(Counter, 4), BeginBal)
' Total payment = principal portion + interest portion
Schedule(Counter, 2) = Schedule(Counter, 3) + Schedule(Counter, 4)
' Determine balance after payment is applied. Check for a balance approaching zero
Schedule(Counter, 5) = BeginBal - Schedule(Counter, 3)
If Schedule(Counter, 5) < 0.01 Then
Schedule(Counter, 5) = 0
Exit For
End If
BeginBal = Schedule(Counter, 5)
Next
' Create a new array that has only as many 'rows' as there are payments to be made
ReDim Schedule2(1 To Counter, 1 To 5) As Double
For Counter2 = 1 To Counter
Schedule2(Counter2, 1) = Schedule(Counter2, 1)
Schedule2(Counter2, 2) = Schedule(Counter2, 2)
Schedule2(Counter2, 3) = Schedule(Counter2, 3)
Schedule2(Counter2, 4) = Schedule(Counter2, 4)
Schedule2(Counter2, 5) = Schedule(Counter2, 5)
Next
' Assign the function return value
AmortSchedTraditional = Schedule2
End Function
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.