VBA Express : Excel - Periodic Payment Based on Specific Initial Dates

Excel

Periodic Payment Based on Specific Initial Dates

Ease of Use

Easy

Version tested with

97, 2000

Submitted by:

chitosunday

Description:

Syntax =monthpmt(Date of principal loan received,Start date of payment, Number of months covered, annual interest rate, amount of principal, no of days in a year 365 or 360, optional rounding)

Discussion:

The excel built-in pmt function is not based on actual number of days in a month. Some users require a specific start date and actual number of days in a month. This user defined function answers the user's specific requirement with an accuracy of two decimal places.

Code:

instructions for use

			Function monthpmt(inidate As Date, strtpmt As Date, nper As Integer, brate As Single, cpv As Double, yrdays As Integer, Optional rdg As Variant) As Double 
     'inidate = beginning date
     'strtpmt = 2nd date
     'nper = total number of period
     'brate= annual rate
     'cpv = principal
     'yrdays=number of days in a year (based)
     'rdg=round off (optional)
    Dim pctr As Integer, marka As Integer 
    Dim rsulta As Double, rsultb As Double, ctrb As Double 
    Dim emi As Double, emib As Double 
    Dim ctr As Byte 
    If DateSerial(Year(strtpmt), Month(strtpmt) + 1, 0) = strtpmt Then ctr = 1 
    emi = -Pmt(brate / 12, nper, cpv) 
    Do 
        rsulta = Abs(cpv) 
        pctr = pctr + 1 
        For i = 1 To nper 
            If i = 1 Then 
                If Not IsMissing(rdg) Then 
                    rsulta = rsulta + WorksheetFunction.Round(rsulta * brate * _ 
                    (strtpmt - inidate) / yrdays, rdg) - emi 
                Else 
                    rsulta = rsulta + (rsulta * brate * (strtpmt - inidate) / yrdays) - emi 
                End If 
                per = strtpmt 
                sel = testdate(ctr, strtpmt, i) 
            Else 
                 
                If Not IsMissing(rdg) Then 
                    rsulta = rsulta + WorksheetFunction.Round(rsulta * brate * _ 
                    (sel - per) / yrdays, rdg) - emi 
                Else 
                    rsulta = rsulta + (rsulta * brate * (sel - per) / yrdays) - emi 
                End If 
                per = sel 
                sel = testdate(ctr, strtpmt, i) 
            End If 
        Next i 
        If WorksheetFunction.Round(rsulta, 2) = 0 Then Exit Do 
        If rsulta > 0 Then 
            marka = 1 
        Else 
            marka = -1 
        End If 
        If pctr < 2 Then 
            ctrb = marka * emi * 0.1 
        Else 
            If rsultb - rsulta = 0 Then Exit Do 
            ctrb = rsulta / (rsultb - rsulta) * ctrb 
        End If 
        emib = emi 
        rsultb = rsulta 
        emi = emib + ctrb 
        If Not IsMissing(rdg) Then emi = WorksheetFunction.Round(emi, rdg) 
    Loop Until pctr > 500 
    monthpmt = emi 
End Function 
 
 
Function testdate(dta, dtb, dtc) As Date 
    If dta = 1 Then 
        testdate = DateSerial(Year(dtb), Month(dtb) + dtc + 1, 0) 
    Else 
        testdate = DateAdd("m", dtc, dtb) 
    End If 
End Function

How to use:

Put the code in a module. The file must be macro enabled. I don't recommend rounding off as it will make the last payment with a balance of a decimal amount.

Test the code:

If you make a amortization table, the last payment should be zero in two decimal palces except if you choose to round it off.

Sample File:

pmtdate.zip 13.86KB

Approved by mdmackillop

This entry has been viewed 154 times.