# ShiftDate() Function: Intelligent Date Adjustments

The ShiftDate() function provides intelligent date handling for your application by helping preserve month-end dates.

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:

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
```