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