Wednesday 1 August 2012

Adding a month to the end of the month: another Excel annoyance:

Ever see a column of month-end payment days do this in a spreadsheet?
 31/08/2005  30/11/2005  28/02/2006  28/05/2006  28/08/2006  28/11/2006  28/02/2007  28/05/2007  28/08/2007  28/11/2007  28/02/2008

Sigh. All VBA developers eventually face the weary task of correcting the VBA.DateTime function library because of this loathsome miscoding by Microsoft:



' Special handling required for adding months at EOM:
' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)
' Business logic is ALWAYS that adding a month to EOM
' gives the end of the following month - 31 Mar 2006.

Here's my solution: I guess you've all got one of your own by now.

The usual health warning applies to ATTRIBUTE statements: they are not recognised by the VBA editor, you have to drag-and-drop the entire module out of the VB IDE, insert the statements manually in notepad, and drag the object back. In case you didn't know, the VB_ProcData attribute places AddDate in the 'Date & Time' category of the Spreadsheet Function Wizard, instead of letting it languish in obscurity under 'User-Defined'.


Public Function AddDate( _
        ByVal DateString As String, _
        Optional ByVal ReferenceDate As Date _
        Optional Subtract As Boolean = False _
        ) As Date
'ATTRIBUTE AddDate.VB_Description="Add a datestring of the form '1m', '10d' or '5y' to the reference date. \r\nBy default the reference date is the current date. \r\nInteger dates only: time expressed as fractional days is discarded. \r\nAll addition and subtraction uses Actual/Actual: no other date convention is implemented.
'ATTRIBUTE AddDate.VB_ProcData.VB_Invoke_Func = " \n2"

'Nigel Heffernan 2001

'THIS CODE IS IN THE PUBLIC DOMAIN

'Add a datestring of the form '1m', '10d' or '5y' to the reference date.
'By default the reference date is the current date.
'Integer dates only: time expressed as fractional days is discarded.
'All addition and subtraction uses Actual/Actual: no other date convention is implemented.

Const VB_HELPFILE As String = "C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA6\1033\VbLR6.chm"
' I'm too lazy to do the proper registry lookup for this help file.

On Error GoTo ErrSub

Dim sNum As String
Dim iLen As Integer
Dim i As Long
Dim strLabel As String

If ReferenceDate = 0 Then
    ReferenceDate = Date
End If

DateString = Trim(UCase(DateString))
DateString = Left(DateString, 16)

If DateString = "SPOT" Then

    DateString = "2" 'Spot price - 'zero-day' plus settlement lag
    strLabel = "d"

ElseIf DateString = "OVERNIGHT" Then

    DateString = "1"
    strLabel = "d"

ElseIf DateString = "O/N" Then

    DateString = "1"
    strLabel = "d"

ElseIf DateString = "DAILY" Then

    DateString = "1"
    strLabel = "d"

ElseIf DateString = "WEEKLY" Then

    DateString = "7"
    strLabel = "d"

ElseIf DateString = "ANNUAL" Then

    DateString = "1"
    strLabel = "yyyy"  ' Year

ElseIf DateString = "YEARLY" Then

    DateString = "1"
    strLabel = "yyyy"  ' Year

ElseIf DateString = "MONTHLY" Then

    DateString = "1"
    strLabel = "m"

ElseIf DateString = "QUARTERLY" Then

    DateString = "3"
    strLabel = "m"

ElseIf DateString = "SEMI-ANNUAL" Then

    DateString = "6"
    strLabel = "m"

ElseIf DateString = "SEMIANNUAL" Then

    DateString = "6"
    strLabel = "m"

ElseIf InStr(DateString, "MONTH") Then

    iLen = InStr(DateString, "M")
    strLabel = "m"      ' Month"

ElseIf InStr(DateString, "YEAR") Then

    iLen = InStr(DateString, "Y")
    strLabel = "yyyy"  ' Year"

ElseIf InStr(DateString, "DAY") Then

    iLen = InStr(DateString, "D")
    strLabel = "d"      ' Day"

ElseIf InStr(DateString, "M") Then

    iLen = InStr(DateString, "M")
    strLabel = "m"      ' Month"

ElseIf InStr(DateString, "Y") Then

    iLen = InStr(DateString, "Y")
    strLabel = "yyyy"  ' Year"

ElseIf InStr(DateString, "D") Then

    iLen = InStr(DateString, "D")
    strLabel = "d"      ' Day"

ElseIf InStr(DateString, "Q") Then

    iLen = InStr(DateString, "Q")
    strLabel = "q"      ' Quarter"

ElseIf InStr(DateString, "W") Then

    iLen = InStr(DateString, "W")
    strLabel = "ww"     ' Week"

ElseIf IsNumeric(DateString) Then

    iLen = Len(DateString)
    strLabel = "d"      ' Day"

Else

    GoTo ErrSub

End If

sNum = Trim(Left(DateString, iLen - 1))

If Not IsNumeric(sNum) Then

    'Trim down until we reach a number

    Do Until IsNumeric(sNum) Or Len(sNum) < 1

        sNum = Left(sNum, Len(sNum) - 1)
        sNum = Trim(sNum)

        'Do not read "5-Year" as "Minus five years"

        If Right(sNum, 1) = "-" Then

            sNum = Left(sNum, Len(sNum) - 1)
            sNum = Trim(sNum)

        End If

    Loop

End If

If Len(sNum) < 1 Then
    GoTo ErrSub

End If

If Not IsNumeric(sNum) Then

    GoTo ErrSub

End If

i = CLng(sNum)

If Subtract Then

    i = -1 * i

End If



' Special handling required for adding months at EOM:
' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)
' Business logic is ALWAYS that adding a month to EOM
' gives the end of the following month - 31 Mar 2006.

If strLabel = "m" Then

    If Month(ReferenceDate) <> Month(ReferenceDate) + 1 Then 'EOM detected

        ReferenceDate = ReferenceDate + 1
        AddDate = DateAdd(strLabel, i, ReferenceDate)
        AddDate = AddDate - 1

    Else

        AddDate = DateAdd(strLabel, i, ReferenceDate)

    End If

Else

    AddDate = DateAdd(strLabel, i, ReferenceDate)

End If

ExitSub:

    Exit Function

ErrSub:

    If Len(Dir(VB_HELPFILE)) > 0 Then

        Err.Raise 13, "AddDate Function", _
         "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _
         & vbCrLf _
         & "Try typing '10d', '3m' or '5y', or the date " & vbCrLf _
         & "interval as a number of calendar days.", _
         VB_HELPFILE, 1000013

    Else

        Err.Raise 13, "AddDate Function", _
         "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _
         &  _
        vbCrLf _
         & "Try typing '10d', '3m' or '5y', or the date " &  _
        vbCrLf _
         & "interval as a number of calendar days."

    End If

     

End Function

No comments:

Post a Comment