Payment Streams With Dates
A series of payments over a period of months (i.e. A monthly payment of royalties over a 36 month period can be modeled with various code structures.) The code below shows examples of how to determine when the period of payments has been satisfied, how to calculate the monthly date that identifies the last payment, how many payments are still outstanding and a complete month-to-month ledger of the payments.
Program Code
Option Explicit
Dim lngMonth As Long
Dim lngDay As Long
Dim lngYear As Long
Dim lngNumberOfContractMonths As Long
Dim i As Long
Dim lngLineCount As Long
Dim dteOriginalStartDate As Date
Dim dteMonthlyStartDate As Date
Dim dteMonthlyEndDateFirstDay As Date
Dim dteMonthlyEndDateLastDay As Date
Dim dteMonthlyEnd
Dim dteMonthlyEndDate As Date
Dim lngNumberOfMonthsPaid As Long
Dim lngRemainingMonthsToBePaid As Long
Dim strYYYYMM As String
' ***********************************************************************
' In all the calculations shown below that refer to:
' Cells(2,1) and Cells(2,2):
' Cells(2,1) Contains The Starting Date of a Payment Stream
' Cells(2,2) Contains the Number Of Months in the Payment Stream
' ***********************************************************************
Public Sub CalculateDateRange()
' ***********************************************************************
' Calculate a String of Start and End Dates for N Months
' This is the Original Creation of monthly dates for payment
' ***********************************************************************
lngLineCount = 1
dteOriginalStartDate = Cells(2, 1)
lngNumberOfContractMonths = Cells(2, 2)
lngMonth = Month(dteOriginalStartDate)
lngYear = Year(dteOriginalStartDate)
For i = 1 To lngNumberOfContractMonths
dteMonthlyStartDate = CDate(lngMonth & "/" & 1 & "/" & lngYear)
lngMonth = lngMonth + 1
If lngMonth > 12 Then
lngMonth = 1
lngYear = lngYear + 1
End If
dteMonthlyEndDate = CDate(lngMonth & "/" & 1 & "/" & lngYear) - 1
lngLineCount = lngLineCount + 1
Cells(lngLineCount, 3) = dteMonthlyStartDate
Cells(lngLineCount, 4) = dteMonthlyEndDate
Next i
End Sub
Public Sub CalculateMonthsBetweenDates()
' ******************************************************************
' DATEDIFF function:
' Calculate The Number Of Months Between Two Dates
' ******************************************************************
Dim dteStartDate As Date, dteEndDate As Date
Dim intNumberOfMonthsDiff As Integer
dteStartDate = "01/01/2020"
dteEndDate = "12/31/2020"
intNumberOfMonthsDiff = DateDiff("m", dteStartDate, dteEndDate)
MsgBox "The number of months between two dates : " & intNumberOfMonthsDiff, vbInformation, "Months Between Two Dates"
End Sub
Public Sub DetermineContractStatusOpenOrClosed()
' ******************************************************************
' EDATE function - Calculate Ending Date of a Starting Date
' and the number of months until completion
'
' Determine if a contract is still open for billing
' ******************************************************************
Dim strCurrentYYYYMM As String
Dim strCalculatedContractEnd_YYYYMM As String
dteOriginalStartDate = Cells(2, 1)
lngNumberOfContractMonths = Cells(2, 2)
' ******************************************************************
' Calculate the Last Month's First Day of the Last Month
' For Example, if a contract ends in March 2022, then:
' dteMonthlyEndDateFirstDay = 03/01/2022
' dteMonthlyEndDateLastDay = 03/31/2022
' Now Compare The Last Month's Date with Current Date To Determine
' If the contract has been satisfied
' ******************************************************************
dteMonthlyEndDateFirstDay = CDate(Application.WorksheetFunction.eDate(dteOriginalStartDate, lngNumberOfContractMonths - 1))
dteMonthlyEndDateLastDay = CDate(Application.WorksheetFunction.eDate(dteOriginalStartDate, lngNumberOfContractMonths)) - 1
strCurrentYYYYMM = Year(Date) & Format(Month(Date), "00")
strCalculatedContractEnd_YYYYMM = Year(dteMonthlyEndDateFirstDay) & Format(Month(dteMonthlyEndDateFirstDay), "00")
If strCurrentYYYYMM > strCalculatedContractEnd_YYYYMM Then
MsgBox ("Contract Is Closed")
Else
MsgBox ("Contract Still Open")
End If
End Sub
Public Sub DetermineRemainingMonthsOfContract()
' ******************************************************************
' DATEDIFF Function - Determine Remaining Contract Months
' Step 1:
' Calculate The Number Of Months Paid:
' Current Month minus Start of Contract + 1
' Step2:
' Calculate The Number Of Remains Months to be Paid:
' Total Contract Months - Number of Months Paid
' ******************************************************************
dteOriginalStartDate = Cells(2, 1)
lngNumberOfContractMonths = Cells(2, 2)
lngNumberOfMonthsPaid = DateDiff("m", dteOriginalStartDate, Date) + 1
' ******************************************************************
' Calculate The Number Of Remaining Months To Be Paid
' lngRemainingMonthsToBePaid = lngNumberOfContractMonths - lngNumberOfMonthsPaid
' Note: On the final payment, the remaining months paid will
' calculate as zero (zero remaining months to be paid
' ******************************************************************
lngRemainingMonthsToBePaid = lngNumberOfContractMonths - lngNumberOfMonthsPaid
End Sub
