Thursday 17 February 2011

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