ShiftDate() Function: Intelligent Date Adjustments

You can save users a lot of time with intelligent date handling.

I first learned this lesson from Allen Browne's excellent article, Intelligent handling of dates at the start of a calendar year. In the article, Allen advocates for automatically rolling back to the previous year when a user enters a fourth quarter (Oct-Dec) month and day in a textbox when the current date is in the first quarter (Jan-Feb).

A similar concept comes into play when adjusting dates.

For example, imagine a recurring task that needs to get done on the last day of each month. If you just take the current year, month, and day and plug them into the DateSerial function while adding one to the month variable, you won't get good results.

What would be better is if we could simply add a month to an existing month-end date and get the following month's month-end date. The ShiftDate() function does that and a whole lot more.

The Approach

The ShiftDate() function returns a new date relative to the start date.

By default, if the date is at month end, then the month end will be preserved.

The new date can come before or after the start date depending on whether the Delta value is negative or positive, respectively.

We can force the returned date to be a business day, but this optional feature is turned off by default.

For the sake of readability, I chose to use a string as the DatePart parameter rather than an enum. While an enum would get us better compile-time checking in VBA, the string option is more readable if we want to call the function from a query or property sheet (where you are forced to call enums by their numerical value rather than their enum item identifier).

The Algorithm

Use a guard clause to verify the calling code passed a supported DatePart value
Use a Select Case statement to branch to appropriate code based on DatePart
For Days, simply add or subtract the Delta value
For Weeks, multiply the Delta value by seven then add or subtract the result
For Years and Months, check if the starting date is the end of a month; if it is, preserve it if MaintainEndOfMonth is True
For Years, add or subtract Delta value to the year portion of the DateSerial function
For whole Months, add or subtract Delta value to the month portion of the DateSerial function
For partial Months, add or subtract the whole number portion of the Delta value to the month portion of DateSerial
For partial Months where MaintainEndOfMonth is True, convert the decimal portion of the Delta value to 1, 2, 3, or 4 weeks
For partial Months where MaintainEndOfMonth is False, convert the decimal portion to the nearest number of days based on an average month (not the current month)
If ForceBusinessDay is True and the shifted date:
• falls on a Saturday then convert to the nearest Friday
• falls on a Sunday then convert to the nearest Monday

The Function

Here is the ShiftDate() function on its own without its required dependencies.

'---------------------------------------------------------------------------------------
' Procedure : ShiftDate
' DateTime  : 2/4/2009 - 6/2/2023
' Author    : Mike Wolfe
' Source    : https://nolongerset.com/shiftdate/
' Purpose   : Returns a new date relative to the startdate.  By default, if the date is
'               at month end, the month end will be preserved.
' Notes     - If MaintainEndOfMonth is True and DatePart is "Month" and Delta is a fraction,
'               then the fraction will be rounded to the nearest 0.25 and 7 days will
'               be added for every .25.
'           - To shift date backwards, pass a negative value as the Delta argument.
'>>> ShiftDate(#1/1/2009#, "Month", 2)
' 3/1/2009
'>>> ShiftDate(#1/31/2009#, "Month", 1)
' 2/28/2009
'>>> ShiftDate(#2/28/2009#, "Months", 2)
' 4/30/2009
'>>> Shiftdate(#2/29/2008#, "Year", 1)
' 2/28/2009
'>>> ShiftDate(#2/28/2011#, "Year", 1)
' 2/29/2012
'>>> ShiftDate(#12/25/2009#, "Week", -2)
' 12/11/2009
'>>> ShiftDate(#10/31/2009#, "Day", -30)
' 10/1/2009
'---------------------------------------------------------------------------------------
'
Function ShiftDate(StartDate As Date, DatePart As String, Delta As Variant, _
                   Optional MaintainEndOfMonth As Boolean = True, _
                   Optional ForceBusinessDay As Boolean = False)
Dim Fraction As Single

    Select Case DatePart
    Case "Year", "Month", "Week", "Day", "Years", "Months", "Weeks", "Days"
        'These are all acceptable values for DatePart
    Case Else
        Err.Raise 5, "DateFunctions.ShiftDate", "Invalid DatePart argument: " & DatePart & _
                                                vbCrLf & vbCrLf & "Must be one of: 'Year', 'Month', 'Week', 'Day'"
    End Select

    Select Case DatePart
    Case "Day", "Days"
        ShiftDate = DateSerial(Year(StartDate), Month(StartDate), Day(StartDate) + Delta)
    Case "Week", "Weeks"
        Const DaysPerWeek As Long = 7
        ShiftDate = DateSerial(Year(StartDate), Month(StartDate), Day(StartDate) + (Delta * DaysPerWeek))
    Case Else
        If MaintainEndOfMonth And IsEndOfMonth(StartDate) Then
            ShiftDate = MonthEnd(StartDate, IIf(DatePart = "Year", 12, 1) * Delta)
        Else
            Select Case DatePart
            Case "Year", "Years": ShiftDate = DateSerial(Year(StartDate) + Delta, Month(StartDate), Day(StartDate))
            Case "Month", "Months"
                ShiftDate = DateSerial(Year(StartDate), Month(StartDate) + Int(Delta), Day(StartDate))
                If Int(Delta) <> Delta Then
                    Fraction = Delta - Int(Delta)
                    If MaintainEndOfMonth Then
                        Select Case Fraction
                        Case Is >= 0.875: ShiftDate = ShiftDate + 28
                        Case Is >= 0.625: ShiftDate = ShiftDate + 21
                        Case Is >= 0.375: ShiftDate = ShiftDate + 14
                        Case Is >= 0.125: ShiftDate = ShiftDate + 7
                        End Select
                    Else
                        'Average out number of days in a month
                        ShiftDate = ShiftDate + VBA.Round(365.25 / 12 * Fraction)
                    End If
                End If
            End Select
        End If
    End Select
    
    If ForceBusinessDay Then
        'If new date falls on a weekend, then we shift accordingly:
        '   If Delta is 0 then go to the closest weekday (Friday for Saturday, Monday for Sunday)
        '   Otherwise, go at least the amount of the delta, but not less:
        '       i.e., one business day after Fri is Mon and one business day before Mon is Fri
        Select Case Weekday(ShiftDate, vbMonday)
        Case 1 To 5
            'Monday - Friday, leave these days alone
        Case 6
            'Saturday
            If Delta <= 0 Then
                ShiftDate = ShiftDate - 1
            Else
                ShiftDate = ShiftDate + 2
            End If
        Case 7
            'Sunday
            If Delta >= 0 Then
                ShiftDate = ShiftDate + 1
            Else
                ShiftDate = ShiftDate - 2
            End If
        End Select
    End If
End Function

The Full Code

The code below includes required helper functions that I've written about in the past:

"Convenience" Date Functions
OPTIONAL: Python-inspired Doc Tests in VBA

The code can be copied and pasted into a blank standard module to get a fully-working solution that you can easily integrate into your projects:

Option Compare Database
Option Explicit

'https://nolongerset.com/convenience-date-functions/
Function IsEndOfMonth(DateToCheck As Date) As Boolean
    IsEndOfMonth = (DateToCheck = DateSerial(Year(DateToCheck), Month(DateToCheck) + 1, 0))
End Function

'Returns 1/31/, 2/28/ or 2/29/, 3/31/, 4/30/, 5/31/, 6/30/, 7/31/, 8/31/, 9/30/, 10/31/, 11/30/, 12/31/
Function MonthEnd(AsOfDate As Date, Optional RelativeMonth As Integer = 0) As Date
    MonthEnd = DateSerial(Year(AsOfDate), Month(AsOfDate) + RelativeMonth + 1, 0)
End Function

'---------------------------------------------------------------------------------------
' Procedure : ShiftDate
' DateTime  : 2/4/2009 - 6/2/2023
' Author    : Mike Wolfe
' Source    : https://nolongerset.com/shiftdate/
' Purpose   : Returns a new date relative to the startdate.  By default, if the date is
'               at month end, the month end will be preserved.
' Notes     - If MaintainEndOfMonth is True and DatePart is "Month" and Delta is a fraction,
'               then the fraction will be rounded to the nearest 0.25 and 7 days will
'               be added for every .25.
'           - To shift date backwards, pass a negative value as the Delta argument.
'>>> ShiftDate(#1/1/2009#, "Month", 2)
' 3/1/2009
'>>> ShiftDate(#1/31/2009#, "Month", 1)
' 2/28/2009
'>>> ShiftDate(#2/28/2009#, "Months", 2)
' 4/30/2009
'>>> Shiftdate(#2/29/2008#, "Year", 1)
' 2/28/2009
'>>> ShiftDate(#2/28/2011#, "Year", 1)
' 2/29/2012
'>>> ShiftDate(#12/25/2009#, "Week", -2)
' 12/11/2009
'>>> ShiftDate(#10/31/2009#, "Day", -30)
' 10/1/2009
'---------------------------------------------------------------------------------------
'
Function ShiftDate(StartDate As Date, DatePart As String, Delta As Variant, _
                   Optional MaintainEndOfMonth As Boolean = True, _
                   Optional ForceBusinessDay As Boolean = False)
Dim Fraction As Single

    Select Case DatePart
    Case "Year", "Month", "Week", "Day", "Years", "Months", "Weeks", "Days"
        'These are all acceptable values for DatePart
    Case Else
        Err.Raise 5, "DateFunctions.ShiftDate", "Invalid DatePart argument: " & DatePart & _
                                                vbCrLf & vbCrLf & "Must be one of: 'Year', 'Month', 'Week', 'Day'"
    End Select

    Select Case DatePart
    Case "Day", "Days"
        ShiftDate = DateSerial(Year(StartDate), Month(StartDate), Day(StartDate) + Delta)
    Case "Week", "Weeks"
        Const DaysPerWeek As Long = 7
        ShiftDate = DateSerial(Year(StartDate), Month(StartDate), Day(StartDate) + (Delta * DaysPerWeek))
    Case Else
        If MaintainEndOfMonth And IsEndOfMonth(StartDate) Then
            ShiftDate = MonthEnd(StartDate, IIf(DatePart = "Year", 12, 1) * Delta)
        Else
            Select Case DatePart
            Case "Year", "Years": ShiftDate = DateSerial(Year(StartDate) + Delta, Month(StartDate), Day(StartDate))
            Case "Month", "Months"
                ShiftDate = DateSerial(Year(StartDate), Month(StartDate) + Int(Delta), Day(StartDate))
                If Int(Delta) <> Delta Then
                    Fraction = Delta - Int(Delta)
                    If MaintainEndOfMonth Then
                        Select Case Fraction
                        Case Is >= 0.875: ShiftDate = ShiftDate + 28
                        Case Is >= 0.625: ShiftDate = ShiftDate + 21
                        Case Is >= 0.375: ShiftDate = ShiftDate + 14
                        Case Is >= 0.125: ShiftDate = ShiftDate + 7
                        End Select
                    Else
                        'Average out number of days in a month
                        ShiftDate = ShiftDate + VBA.Round(365.25 / 12 * Fraction)
                    End If
                End If
            End Select
        End If
    End Select
    
    If ForceBusinessDay Then
        'If new date falls on a weekend, then we shift accordingly:
        '   If Delta is 0 then go to the closest weekday (Friday for Saturday, Monday for Sunday)
        '   Otherwise, go at least the amount of the delta, but not less:
        '       i.e., one business day after Fri is Mon and one business day before Mon is Fri
        Select Case Weekday(ShiftDate, vbMonday)
        Case 1 To 5
            'Monday - Friday, leave these days alone
        Case 6
            'Saturday
            If Delta <= 0 Then
                ShiftDate = ShiftDate - 1
            Else
                ShiftDate = ShiftDate + 2
            End If
        Case 7
            'Sunday
            If Delta >= 0 Then
                ShiftDate = ShiftDate + 1
            Else
                ShiftDate = ShiftDate - 2
            End If
        End Select
    End If
End Function

The Approach

The Algorithm

The Function

The Full Code

Sample Usage