Calculate a date, but do not count weekends or holidays

[bmj121]

So I currently have a set of code that will calculate a date from a start date and will make sure the end date does not land on a weekend or a holiday. Which is great. But I also need it to not count those weekends or holidays when it is adding the number of days to the start date. Here is the function I have now:

Function fnctAddDate(sPubDate, iIncrement) As String
Dim holidays(19, 11)
    For i = 1 To 19
        If Format$(sPubDate, "yyyy") = holidays(i, 0) Then
            sReturnVolume = i
            i = 19
        End If
    Next
 
 
    bTest = True: nDate = Format(DateAdd("d", iIncrement - 1, sPubDate), "mmmm d, yyyy")
    Do While sDOW = "Sat" Or sDOW = "Sun" Or bTest = True
        nDate = DateAdd("d", 1, nDate)
        sDOW = Format$(nDate, "ddd")
        If sDOW <> "Sat" And sDOW <> "Sun" Then
    bTest = CheckHoliday(sReturnVolume, nDate)
        End If
    Loop
 
    fnctAddDate = nDate
 
End Function

[Rabbit]

Keep a separate count of days added and add one day at a time, checking if it's a holiday or weekend.

[ADezii]

Here is my own Algorithm that I created to count X number of days after a Start Date, excluding Saturdays, Sundays, and Holidays. I maintain all Holidays in a [Date] Field in a Table named tblHolidays where they are referenced. The Debug.print statement accurately displays the Date Sequence, Day Counter, and Day of the Week. Notice that there are no Saturdays, Sundays, or Valentines Days displayed (Valentines Day is the only Holiday within the Range, namely 20 days from February 1, 2013). I'm sure that you can adapt this to your own specific needs should you so desire.

1. Function Definition:
   

   Public Function fCalcWorkDays2(dteStartDate As Date, lngNumOfDays As Long)
   Dim lngCount As Long
   Dim lngCtr As Long
   Dim dteDate As Date
    
   lngCount = 0
   lngCtr = 1
    
   Debug.Print "Date", "Day Count", "Weekday"
    
   Do
     dteDate = DateAdd("d", lngCtr, dteStartDate)
       Select Case Weekday(dteDate)
         Case 7, 1      'Saturday and Sunday, do nothing
         Case Else      'Monday thru Friday, OK
           'Is it a Holiday as posted in tblHolidays?
           If DCount("*", "tblHolidays", "[Date] = #" & dteDate & "#") < 1 Then     'NOT Holiday
             lngCount = lngCount + 1       'Increment Counter
               Debug.Print dteDate, lngCount, Weekday(dteDate)
           End If
       End Select
       lngCtr = lngCtr + 1
   Loop While lngCount < lngNumOfDays
     fCalcWorkDays2 = dteDate
   End Function

2. Sample Function Call:
   

   Debug.Print "--------------------------------------------------"
   Debug.Print "20 workdays from 2/1/2014, excluding Holidays is: " & _
                fCalcWorkDays2(#2/1/2014#, 20)
   Debug.Print "--------------------------------------------------"

3. Debug.Print OUTPUT:
   

   --------------------------------------------------
   Date          Day Count     Weekday
   2/3/2014       1             2 
   2/4/2014       2             3 
   2/5/2014       3             4 
   2/6/2014       4             5 
   2/7/2014       5             6 
   2/10/2014      6             2 
   2/11/2014      7             3 
   2/12/2014      8             4 
   2/13/2014      9             5 
   2/17/2014      10            2 
   2/18/2014      11            3 
   2/19/2014      12            4 
   2/20/2014      13            5 
   2/21/2014      14            6 
   2/24/2014      15            2 
   2/25/2014      16            3 
   2/26/2014      17            4 
   2/27/2014      18            5 
   2/28/2014      19            6 
   3/3/2014       20            2 
   20 workdays from 2/1/2014, excluding Holidays is: 3/3/2014
   --------------------------------------------------

[paultey]

Hi ADezii,

I use ur Algorithm and my regional setting is non-us date. It work okay for weekend but for holidays it cannot work as my holiday is d/m/yyyy format. Please kindly advice. Thank.

[PhilOfWalton]

Just to add my ha'p'orth, the following functions give various holiday dates.

Option Compare Database
Option Explicit
 
Public Function EasterDate(Yr As Integer) As Date
 
    Dim Da As Integer
    Da = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
    EasterDate = DateSerial(Yr, 3, 1) + Da + (Da > 48) + 6 - ((Yr + Yr \ 4 + _
    Da + (Da > 48) + 1) Mod 7)
 
End Function
 
 
Public Function GoodFriday(Yr As Integer) As Date
 
    GoodFriday = DateAdd("d", -2, EasterDate(Yr))
 
End Function
 
Public Function EasterMonday(Yr As Integer) As Date
 
    EasterMonday = DateAdd("d", 1, EasterDate(Yr))
 
End Function
 
Public Function AscensionDay(Yr As Integer) As Date
 
    AscensionDay = DateAdd("d", 39, EasterDate(Yr))
 
End Function
 
Public Function FirstSpringHoliday(Yr As Integer) As Date
 
    FirstSpringHoliday = DateSerial(Yr, 5, ((7 - Weekday(DateSerial(Yr, 5, 7))) + 2) Mod 7)
    'DateSerial(Year(mydte), Month(mydte), ((7 - Weekday(DateSerial(Year(mydte), Month(mydte), 7))) + 2) mod 7)
 
End Function
 
Public Function LastSpringHoliday(Yr As Integer) As Date
 
    Dim TheDay As Integer
 
    TheDay = Day(DateSerial(Yr, 5, ((7 - Weekday(DateSerial(Yr, 5, 7))) + 2) Mod 7))     ' First Spring bank holiday
 
    TheDay = TheDay + 28
    If TheDay <= 31 Then
        LastSpringHoliday = DateAdd("d", 28, DateSerial(Yr, 5, ((7 - Weekday(DateSerial(Yr, 5, 7))) + 2) Mod 7))
    Else
        LastSpringHoliday = DateAdd("d", 21, DateSerial(Yr, 5, ((7 - Weekday(DateSerial(Yr, 5, 7))) + 2) Mod 7))
    End If
 
End Function
 
Public Function ChristmasDay(Yr As Integer) As Date
 
    ChristmasDay = DateSerial(Yr, 12, 25)
 
End Function
 
Public Function BoxingDay(Yr As Integer) As Date
 
    BoxingDay = DateSerial(Yr, 12, 26)
 
End Function
 
Public Function NewYearsDay(Yr As Integer) As Date
 
    NewYearsDay = DateSerial(Yr, 1, 1)
 
End Function
 
Public Function Scots2January(Yr As Integer) As Date
 
    Scots2January = DateSerial(Yr, 1, 2)
 
End Function
 
Public Function FirstAugustHoliday(Yr As Integer) As Date
 
    FirstAugustHoliday = DateSerial(Yr, 8, ((7 - Weekday(DateSerial(Yr, 8, 7))) + 2) Mod 7)
    'DateSerial(Year(mydte), Month(mydte), ((7 - Weekday(DateSerial(Year(mydte), Month(mydte), 7))) + 2) mod 7)
 
End Function
 
Public Function LastAugustHoliday(Yr As Integer) As Date
 
    Dim TheDay As Integer
 
    TheDay = Day(DateSerial(Yr, 8, ((7 - Weekday(DateSerial(Yr, 8, 7))) + 2) Mod 7))     ' First Spring bank holiday
 
    TheDay = TheDay + 28
    If TheDay <= 31 Then
        LastAugustHoliday = DateAdd("d", 28, DateSerial(Yr, 8, ((7 - Weekday(DateSerial(Yr, 8, 7))) + 2) Mod 7))
    Else
        LastAugustHoliday = DateAdd("d", 21, DateSerial(Yr, 8, ((7 - Weekday(DateSerial(Yr, 8, 7))) + 2) Mod 7))
    End If
 
End Function
 
Public Function ThanksgivingDay(Yr As Integer) As Date
 
    ThanksgivingDay = DateSerial(Yr, 11, 29 - Weekday(DateSerial(Yr, 11, 1), vbFriday))
 
 End Function
 
 
Public Function DOWsInMonth(Yr As Integer, M As Integer, DOW As Integer) As Integer
 
    '? DOWsInMonth(1998, 5, 2) gives 5
 On Error GoTo DOWsInMonth_Exit
 
    Dim i As Integer
    Dim Lim As Integer
 
    Lim = Day(DateSerial(Yr, M + 1, 0))
 
    DOWsInMonth = 0
    For i = 1 To Lim
        If Weekday(DateSerial(Yr, M, i)) = DOW Then
            DOWsInMonth = DOWsInMonth + 1
        End If
    Next i
    Exit Function
 
DOWsInMonth_Exit:
    DOWsInMonth = 0
 
End Function
 

Phil

[Saved by Grace]

Good Evening. This function is exactly what I need for a db that I am building. However, I cannot make it work. It does not return a value when I attempt to use it. I have entered it in a module in Access 2013. Can I ask for more assistance, please?

[NeoPa]

Only by writing your own question in a separate thread. Not asking it in this one, although a link from and/or to this one is perfectly permissible.

Send me a PM if you need more help using the site.