dateadd that add workdays, weekend is friday and saturday

halo



i need to add or decrease work days in a query field.
i found office support great solution right here http://support2.microsoft.com/kb/115489

but i need to set the weekend as friday-saturday and not saturday-sunday.

i tried to change it on my own but my VBA skill is very basic.

Please show us what you have tried.

manwe_sulimo,

Here is a function to AddWorkdays based on the Microsoft function you mentioned. This allows you to change the weekend days. The weekend days must be contiguous (Friday/Saturday; Tuesday/Wednesday; etc). The default is Saturday/Sunday. There are comments within the code.

To use it:
Create a standard module. Copy the code below and paste it in the module.
See the usage samples within the comments.


Good luck.

Code:

'---------------------------------------------------------------------------------------
' Procedure : DateAddWj
' Author    : mellon
' Date      : 28/02/2015
' Purpose   : To Add a number of WorkDays to a given Date. This function allows for non standard weekends.
'
'  PARAMETERS:
'  TheDate :  the starting date  or the Date to which you are adding a number of days
'  Interval:  the number of workdays to be added to TheDate
' Optional Parameters follow:
'  WeekEndStart : the day number on which the week end starts
'                 weekdays numbers Sun(1) ----Sat(7),
'                 Defaults to 7 (Saturday) if no parameter supplied
'  PRTDebug : a Boolean to Print or suppress debug statements within the funtion code
'                 the values are True for Print to immediate window
'                 Defaults to False -- do not print debug statements.
'
' NOTE:  This routine does not handle Holidays nor fractional intervals *****************************
'*******                                                                *****************************
'****************************************************************************************************
' Typical usage:
'
' DateAddWj(testdate, interval, 6, True) :: add interval days to TestDate where weekend starts on Friday, Print debug statements
'
' DateAddWj(testdate, interval) :: add interval days to TestDate(default weekend start Saturday; no print of debug statements)
'
'  DateAddWj(testdate, interval,,True) ::add interval days to  TestDate(default weekend; Print debug statements to the immediate  window)
'
' so normal weekend sat, sun would have weekendstart =7
'    This is based roughly on the material
'FROM M$oft http://support2.microsoft.com/kb/115489
'==========================================================
' The DateAddWj() function provides a workday substitute
' for DateAdd("w", number, date). This function performs
' error checking and ignores fractional Interval values.
'==========================================================
'---------------------------------------------------------------------------------------
'
Function DateAddWj(ByVal TheDate, ByVal interval, _
         Optional WeekEndStart As Integer = 7, _
         Optional PRTDebug As Boolean = False) As Date

          Dim Weeks As Long, OddDays As Long, Temp As Long
          Dim wkEnd1 As Long, wkEnd2 As Long
            
10        wkEnd1 = WeekEndStart
20        wkEnd2 = IIf(wkEnd1 > 6, 1, WeekEndStart + 1)

30        If PRTDebug Then Debug.Print "Weekend is " & WeekdayName(wkEnd1) & "  and " & WeekdayName(wkEnd2)
40        On Error GoTo DateAddWj_Error
50        If Not IsDate(TheDate) Then GoTo DateAddWj_Error
60        If Weekday(TheDate) <> wkEnd1 And Weekday(TheDate) <> wkEnd2 Then
70            DateAddWj = TheDate
80        ElseIf interval = 0 Then
90            DateAddWj = TheDate
100           Exit Function
110       ElseIf interval > 0 Then
120           interval = Int(interval)

              ' Make sure TheDate is a workday (round down).
130           Temp = Weekday(TheDate)
140           If PRTDebug Then Debug.Print "Weekday of the starting date is " & WeekdayName(Temp)

150           If Temp = wkEnd2 Then
160               TheDate = TheDate - 2
170           ElseIf Temp = wkEnd1 Then
180               TheDate = TheDate - 1
190           End If

200       End If
          ' Calculate Weeks and OddDays.
210       Weeks = Int(interval / 5)
220       OddDays = interval - (Weeks * 5)
230       TheDate = TheDate + (Weeks * 7)

          ' Take OddDays weekend into account.
240       If (DatePart("w", TheDate) + OddDays) > 6 Then
250           TheDate = TheDate + OddDays + 2
260       Else
270           TheDate = TheDate + OddDays
280       End If

290       DateAddWj = TheDate
          ' Interval is < 0
300       If interval < 0 Then
310           interval = Int(-interval)    ' Make positive & subtract later.
320       End If

          ' Make sure TheDate as calculated is a workday.
          ' If not  round up  1 for lastDay of weekend, 2 if first day of weekend
          '**********************************************************************
330       Temp = Weekday(TheDate)
340        If PRTDebug Then Debug.Print "Weekday of calculated Date before final  check for workday is  " & WeekdayName(Weekday(TheDate))

350       If Temp = wkEnd2 Then
360           TheDate = TheDate + 1   'add 1 day if calculated date is end of weekend
370       ElseIf Temp = wkEnd1 Then
380           TheDate = TheDate + 2   'add 2 days if calculated date is start of weekend
390       End If
          
          ' This is the result of calculations on TheDate
400        If PRTDebug Then Debug.Print "Weekday of final calculated Date is  " & WeekdayName(Weekday(TheDate))

410       DateAddWj = TheDate

420       On Error GoTo 0
430       Exit Function

DateAddWj_Error:

440        MsgBox "Error " & Err.Number & " (" & Err.Description &  ") in procedure DateAddWj of Module AWF_Related"

End Function

thx! looks great, and work great.
if u change it just for me - u r awesome ;-)