Results 1 to 3 of 3
  1. #1
    orange's Avatar
    orange is offline Moderator
    Windows 10 Access 2010 32bit
    Join Date
    Sep 2009
    Location
    Ottawa, Ontario, Canada; West Palm Beach FL
    Posts
    16,715

    Add or Subtract Business Days from a Given Date

    Here is a function and test procedure to Add or Subtract Business Days/Working Days from a specified date. This considers Weekend Days and Holidays as NOT Business/Work days.
    The holiday table is named tblHolidays and includes a field HolidayDate that is defined as a Date datatype. The weekend days are Saturday and Sunday.

    Code:
    '---------------------------------------------------------------------------------------
    ' Procedure : aWorkdays
    ' Author    : mellon
    ' Date      : 17-Aug-2016
    ' Purpose   : A sample routine to ADD or SUBTRACT a specified number of
    'Business days/work days to a starting Date. This example uses
    'weekend days Saturday and Sunday.
    ' It also respects holidays, if you have a table called tblHolidays with field(s)
    ' HolidayDate defined as a Date datatype. (you may have other fields in your table)
    '
    ' My sample HOLIDAY table data is: (fictitious holidays for demo)
    ' ID  Description    HolidayDate
    '8   NewYears       1 - Jan - 2016
    '4   xxxMonday      18 - Jan - 2016
    '1   MadeUpHoliday  26 - Jan - 2016
    '2   AnotherHoliday 29 - Jan - 2016
    '3   holidayWeekend 30 - Jan - 2016
    '5   HolidaySpecial  1 - Feb - 2016
    '6   march day      17 - Mar - 2016
    '7   aprilfools      1 - Apr - 2016
    '
    ' If you set the Adding option to False, the routine will SUBTRACT business days from
    ' the start date.
    
    ' If you set the ShowDebug option to True, it will log details to the immediate window
    '
    'Sample calls:
    '
    ' Call to Add 13 Business days to Feb 23, 2016 with Debug details
    '   where MyDate = #23-Feb-2016# and daysToadd = 13
    '   aWorkdays(myDate, daystoAdd,  , True)
    '                                                             +-----> Debug
    '    
    ' Call to Subtract 5 Business days from Feb 23, 2016 with no debug details
    '   MyDate as above; daystoadd=5
    '   aWorkdays(myDate, daystoAdd, False, False)
    '                                                          +      +------> no debug
    '                                                          |
    '                                                         +-------------> not Adding
    '---------------------------------------------------------------------------------------
    '
    Function aWorkdays(startDate As Date, _
                       NumBusinessDays As Long, _
                       Optional Adding As Boolean = True, _
                       Optional ShowDebug As Boolean = False) As Date
    
    
        Dim Enddate As Date
        Dim TempDate As Date
        Dim numWorkDays As Long
        Dim BusinessDays As Integer
        Dim i As Integer
        Dim isWeekend As Boolean  'True if the date is a weekend day
        Dim isHoliday As Boolean  'True if the date is a Holiday
    
    
    10  On Error GoTo aWorkdays_Error
    
    20  numWorkDays = NumBusinessDays
    30  TempDate = startDate
        Dim TWeekDay As Integer
    
    40  For i = 1 To 9999    'just a large number
            'reset the Holiday and weekendday flags
    50      isHoliday = False
    60      isWeekend = False
    70      If ShowDebug Then Debug.Print "Tempdate is   " & TempDate
            'Get some facts
            'is this date a holiday
    80      If DCount("*", "tblHolidays", "HolidayDate=#" & TempDate & "#") = 1 Then
    90          isHoliday = True
    100         If ShowDebug Then Debug.Print TempDate & "  is a Holiday--------H"
    110     End If
    
            'is this date a weekend
    120     TWeekDay = WeekDay(TempDate)
    130     Select Case TWeekDay
            Case 1, 7  'is weekend not a business/work day
    140         isWeekend = True
    150         If ShowDebug Then Debug.Print TempDate & "  is a weekend day----W"
    160     Case Else
    170     End Select
    
            'Count the Business day
    180     If Not isHoliday And Not isWeekend Then
    190         BusinessDays = BusinessDays + 1
    200         If ShowDebug Then Debug.Print TempDate & " is a Business Day"
    
    210     End If
    
            'check if we have found the end date
    220     If BusinessDays = numWorkDays Then
    230         GoTo Finished
    240     ElseIf Adding Then           'this handles Adding
    250         TempDate = TempDate + 1
    260     Else
    270         TempDate = TempDate - 1  'this does the subtracting
    280     End If
    290 Next i
    Finished:
    300 If ShowDebug Then
    310     If Adding Then
    320         Debug.Print "Adding " & numWorkDays & " business days to " & startDate & "  is " & TempDate
    330     Else
    340         Debug.Print "Subtracting " & numWorkDays & " business days from " & startDate & "  is " & TempDate
    350     End If
    360 End If
    370 aWorkdays = TempDate
    
    380 On Error GoTo 0
    390 Exit Function
    
    aWorkdays_Error:
    
    400 MsgBox "Error " & err.number & " in line " & Erl & " (" & err.Description & ") in procedure aWorkdays of Module mellonAccessRelated"
    End Function
    Sample testing routine:
    Code:
    Sub testAWorkdays()
    Dim myDate As Date: myDate = #1/26/2016#
    Dim daystoAdd As Long: daystoAdd = 3
    Debug.Print daystoAdd & " Business Days From " & myDate & "  is " & aWorkdays(myDate, daystoAdd, False, True)
    End Sub
    Sample outputimmediate window)
    Tempdate is 26-Jan-2016
    26-Jan-2016 is a Holiday--------H
    Tempdate is 25-Jan-2016
    25-Jan-2016 is a Business Day
    Tempdate is 24-Jan-2016
    24-Jan-2016 is a weekend day----W
    Tempdate is 23-Jan-2016
    23-Jan-2016 is a weekend day----W


    Tempdate is 22-Jan-2016
    22-Jan-2016 is a Business Day
    Tempdate is 21-Jan-2016
    21-Jan-2016 is a Business Day
    Subtracting 3 business days from 26-Jan-2016 is 21-Jan-2016
    3 Business Days From 26-Jan-2016 is 21-Jan-2016


    Another sample test:
    Sub testAWorkdays()
    Dim myDate As Date: myDate = #1/26/2016#
    Dim daystoAdd As Long: daystoAdd = 3
    Debug.Print daystoAdd & " Business Days From " & myDate & " is " & aWorkdays(myDate, daystoAdd, True, True)
    End Sub

    Output from this test:

    Tempdate is 26-Jan-2016
    26-Jan-2016 is a Holiday--------H
    Tempdate is 27-Jan-2016
    27-Jan-2016 is a Business Day
    Tempdate is 28-Jan-2016
    28-Jan-2016 is a Business Day
    Tempdate is 29-Jan-2016
    29-Jan-2016 is a Holiday--------H
    Tempdate is 30-Jan-2016
    30-Jan-2016 is a Holiday--------H
    30-Jan-2016 is a weekend day----W
    Tempdate is 31-Jan-2016
    31-Jan-2016 is a weekend day----W
    Tempdate is 01-Feb-2016
    01-Feb-2016 is a Holiday--------H
    Tempdate is 02-Feb-2016
    02-Feb-2016 is a Business Day
    Adding 3 business days to 26-Jan-2016 is 02-Feb-2016
    3 Business Days From 26-Jan-2016 is 02-Feb-2016

  2. #2
    vicsaccess's Avatar
    vicsaccess is offline Competent Performer
    Windows 8 Access 2013
    Join Date
    Apr 2015
    Posts
    451
    As always Orange, thank you. This one is going into my code library for future use.

  3. #3
    gutarkomp is offline Novice
    Windows 10 Access 2016
    Join Date
    May 2017
    Posts
    4
    I am looking for something like this but, for business hours.
    ie:
    Start Time = 1/1/2017 10:30 AM
    End Time = 1/2/2017 9:30 AM
    Total Time = 23 Hours
    Business Hours = 7 Hours
    If business hours are 7:30 AM – 3:30 PM

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 2
    Last Post: 08-16-2019, 08:36 AM
  2. Replies: 3
    Last Post: 04-03-2013, 05:53 PM
  3. CRITERIA only looks at the LAST 20 BUSINESS DAYS
    By taimysho0 in forum Queries
    Replies: 3
    Last Post: 12-06-2011, 06:27 PM
  4. Subtract From Previous Record Using a Date
    By txrules in forum Queries
    Replies: 1
    Last Post: 12-30-2010, 02:10 AM
  5. Replies: 9
    Last Post: 03-19-2010, 10:37 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums