Any way to do this in one SQL Query? 2

[Swi]

Been out of SQL for a while. What would be the best strategy to determine the below calculation?

Days-in-System Calculation
Days in System = (Last Scan Date – First Scan Date) – (Adjustment for Sunday/Holiday)
The adjustment for Sunday/Holiday is determined using the following logic:
a. If the last scan date falls on a day immediately following a Sunday or holiday, then subtract 1 from the days-in-system value.
b. If the last scan date falls on a day immediately following a Sunday, and that Sunday is immediately preceded by a holiday, then subtract 2 from the days-in-system value.

Swi

 

[dhookom]

Do you have a table of holidays? If not, that is a good place to start. I believe there is an FAQ in this site for creating such a table.

Duane
Hook'D on Access
MS Access MVP

 

[PHV]

What are Last Scan Date and First Scan Date ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Swi]

Last scan date and first scan date are actually entries in another table that are scans on when/where a piece of mail is in the mail stream.

Swi

 

[MajP]

if you need to make a table of holidays here is the code to make the federal holidays. You would have to add/modify for your specific business rules

Public Sub FillHolidays(StartYear As Integer, EndYear As Integer)

  Dim HolidayDate As Date
  Dim CurrentYear As Integer

 
  For CurrentYear = StartYear To EndYear
      'New Years
      HolidayDate = CDate("01/01/" & CurrentYear)
      InsertHoliday HolidayDate, "New Years"
       'ML King 3rd Monday of Jan
       HolidayDate = DayOfNthWeek(CurrentYear, 1, 3, vbMonday)
       InsertHoliday HolidayDate, "Martin Luther King Day"
      'Presidents Day  3rd Monday of Feb
      HolidayDate = DayOfNthWeek(CurrentYear, 2, 3, vbMonday)
      InsertHoliday HolidayDate, "Presidents Day"
     'Memorial Day    Last Monday of May
      HolidayDate = LastMondayInMonth(CurrentYear, 5)
      InsertHoliday HolidayDate, "Memorial Day"
     'Independance Day
      HolidayDate = CDate("07/04/" & CurrentYear)
      InsertHoliday HolidayDate, "Independence Day"
     'Labor Day   1st Monday of Sep
      HolidayDate = DayOfNthWeek(CurrentYear, 9, 1, vbMonday)
      InsertHoliday HolidayDate, "Labor Day"
     'Columbus Day    2nd Monday of Oct
      HolidayDate = DayOfNthWeek(CurrentYear, 10, 2, vbMonday)
      InsertHoliday HolidayDate, "Columbus Day"
    ' Veteranss Day
    ' Although originally scheduled for celebration on November 11,
    ' starting in 1971 Veterans Day was moved to the fourth Monday of October.
    ' In 1978 it was moved back to its original celebration on November 11.
      HolidayDate = CDate("11/11/" & CurrentYear)
      InsertHoliday HolidayDate, "Verterans Day"
    'Thanksgiving Day  4th Thursday of Nov
      HolidayDate = DayOfNthWeek(CurrentYear, 11, 4, vbThursday)
      InsertHoliday HolidayDate, "Thanksgiving"
    'CHRISTMAS
      HolidayDate = CDate("12/25/" & CurrentYear)
      InsertHoliday HolidayDate, "Christmas"
   Next CurrentYear
End Sub
Public Sub InsertHoliday(HolidayDate As Date, HolidayName As String)
     Dim strSql As String
     strSql = "Insert into tblHolidays (HolidayDate, HolidayName) values (#" & Format(HolidayDate, "mm/dd/yyyy") & "# , '" & HolidayName & "')"
     Debug.Print strSql
     CurrentDb.Execute strSql
End Sub

 

[Swi]

Ok, so the above code is great to see if a specific date is a holiday. I can also check to see if it is a Sunday however what I would like to do is the following:

1. Supply a date range to a function
2. Have it figure out have many days within that date range are a holiday or Sunday

Without cycling through record by record to accomplish this is there a way to do this in an SQL statement?

Thanks.

Swi

 

[Swi]

Also, the functions for DayOfNthWeek and LastMondayInMonth are missing. Can you please send? Thanks.

Swi

 

[MajP]

Public Function DayOfNthWeek(intYear As Integer, intMonth As Integer, N As Integer, vbDayOfWeek As Integer) As Date
  'Thanksgiving is the 4th thursday in November(11)
  'dayOfNthWeek(theYear,11,4,vbThursday)
   DayOfNthWeek = DateSerial(intYear, intMonth, (8 - Weekday(DateSerial(intYear, intMonth, 1), _
 (vbDayOfWeek + 1) Mod 8)) + ((N - 1) * 7))
End Function
Function LastMondayInMonth(intYear As Integer, intMonth As Long) As Date
    'Used for memorial day
    Dim LastDay As Date
    'define last day of the month of interest:
    LastDay = DateSerial(intYear, intMonth + 1, 0)
    'use to get last monday:
    LastMondayInMonth = LastDay - Weekday(LastDay, vbMonday) + 1
End Function

other functions that may be useful

Public Function dateAddNoWeekends(dtmDate As Variant, intDaysToAdd As Integer) As Variant
  'Pass in your date: dtmDate
  'Pass in the number of days to add: intDaysToAdd

  'Direction: Determine if you are adding or subtracting days.  If days to add is negative (-1), positive (1), or
  '0 then do nothing.
  Dim direction As Integer
  'You need to loop the number of days. But only increment the counter if it is not a weekend. Not a weekend is
  ' a weekday value of 1 (vbSunday) or 7 (vbSaturday)
  Dim intCount As Integer
  'just make sure they pass in legitimate values or do nothing
 If IsNumeric(intDaysToAdd) And IsDate(dtmDate) Then
    'set the return value equal the date passed in.
    dateAddNoWeekends = dtmDate
    'Determine if you add a day, delete a day, or exit the function
    If intDaysToAdd < 0 Then
     direction = -1
    ElseIf intDaysToAdd > 0 Then
     direction = 1
    Else
     Exit Function
    End If
    'Start looping until you go intDaysToAdd, but only increment if not a weekend
    Do
        dateAddNoWeekends = dateAddNoWeekends + 1 * (direction)
        If Not isWeekend(dateAddNoWeekends) Then
        intCount = intCount + 1
        End If
    Loop Until intCount = Abs(intDaysToAdd)
    'need the absolute value because if they pass in -5 you want to
    'increment 5 times
End If
End Function

Public Function isWeekend(ByVal dtmDate As Date) As Boolean
  If Weekday(dtmDate) = vbSaturday Or Weekday(dtmDate) = vbSunday Then isWeekend = True
End Function
Public Function isHolidayFromTable(ByVal dtmDate As Date) As Boolean
  Dim strWhere As String
  Const cstrHolidayTable  As String = "tblHoliday"
  Const cstrHolidayField  As String = "HolidayDate"
  strWhere = cstrHolidayField & " = " & Format(dtmDate, "\#m\/d\/yyyy\#")
  'MsgBox dExists(cstrHolidayTable, strWhere)
  isHolidayFromTable = dExists(cstrHolidayTable, strWhere)
End Function
Public Function dateAddNoWeekendsHolidays(dtmDate As Variant, intDaysToAdd As Integer) As Variant
  'Pass in your date: dtmDate
  'Pass in the number of days to add: intDaysToAdd

  'Direction: Determine if you are adding or subtracting days.  If days to add is negative (-1), positive (1), or
  '0 then do nothing.
  Dim direction As Integer
  'You need to loop the number of days. But only increment the counter if it is not a weekend. Not a weekend is
  ' a weekday value of 1 (vbSunday) or 7 (vbSaturday)
  Dim intCount As Integer
  'just make sure they pass in legitimate values or do nothing
 If IsNumeric(intDaysToAdd) And IsDate(dtmDate) Then
    'set the return value equal the date passed in.
    dateAddNoWeekendsHolidays = dtmDate
    'Determine if you add a day, delete a day, or exit the function
    If intDaysToAdd < 0 Then
     direction = -1
    ElseIf intDaysToAdd > 0 Then
     direction = 1
    Else
     Exit Function
    End If
    'Start looping until you go intDaysToAdd, but only increment if not a weekend or holiday
    Do
        dateAddNoWeekendsHolidays = dateAddNoWeekendsHolidays + 1 * (direction)
        If Not isWeekend(dateAddNoWeekendsHolidays) And Not isHolidayFromTable(dateAddNoWeekendsHolidays) Then
         intCount = intCount + 1
        End If
    Loop Until intCount = Abs(intDaysToAdd)
    'need the absolute value because if they pass in -5 you want to
    'increment 5 times
End If
End Function

 

[Swi]

Wow! Thanks.

Swi

 

[Swi]

One other missing function: dExists

Thanks.

Swi

 

[MajP]

That function was a simple wrapper on the dcount function, original used when D aggregate functions were very slow. Not really an issue anymore. Here is also an enhanced Dlookup.

Public Function dExists(Domain As String, Optional Criteria As String = "") As Boolean
  On Error GoTo errLabel
  Dim db As DAO.Database          'This database.
  Dim rs As DAO.Recordset         'To retrieve the value to find.
  Dim strSql As String            'SQL statement.
  'Build the SQL string.
   strSql = "SELECT COUNT(*) as IntCount " & " FROM " & Domain
   If Criteria <> "" Then
        strSql = strSql & " WHERE " & Criteria
   End If
   strSql = strSql & ";"
    'Lookup the value.
    Set db = DBEngine(0)(0)
    Set rs = db.OpenRecordset(strSql, dbOpenForwardOnly)
    dExists = rs!intCount > 0
    Set rs = Nothing
    Set db = Nothing
    Exit Function
errLabel:
    MsgBox Err.Number & Err.Description & vbCrLf & strSql
End Function

Public Sub TestDexists()
  Dim startTime As Long
  Dim blnExists As Boolean
  startTime = Timer
  blnExists = dExists("[order Details]", "OrderID = 10657")
  MsgBox blnExists & " " & Timer - startTime
  startTime = Timer
  DLookup "OrderID", "[order Details]", "OrderID = 10657"
  MsgBox blnExists & " " & Timer - startTime
  startTime = Timer
  ELookup "OrderID", "[order Details]", "OrderID = 10657"
  MsgBox blnExists & " " & Timer - startTime
End Sub
Public Function ELookup(Expr As String, Domain As String, Optional Criteria As Variant, _
    Optional OrderClause As Variant) As Variant
On Error GoTo Err_ELookup
    'Purpose:   Faster and more flexible replacement for DLookup()
    'Arguments: Same as DLookup, with additional Order By option.
    'Return:    Value of the Expr if found, else Null.
    '           Delimited list for multi-value field.
    'Author:    Allen Browne. allen@allenbrowne.com
    'Updated:   December 2006, to handle multi-value fields (Access 2007 and later.)
    'Examples:
    '           1. To find the last value, include DESC in the OrderClause, e.g.:
    '               ELookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
    '           2. To find the lowest non-null value of a field, use the Criteria, e.g.:
    '               ELookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
    'Note:      Requires a reference to the DAO library.
    Dim db As DAO.Database          'This database.
    Dim rs As DAO.Recordset         'To retrieve the value to find.
    Dim rsMVF As DAO.Recordset      'Child recordset to use for multi-value fields.
    Dim varResult As Variant        'Return value for function.
    Dim strSql As String            'SQL statement.
    Dim strOut As String            'Output string to build up (multi-value field.)
    Dim lngLen As Long              'Length of string.
    Const strcSep = ","             'Separator between items in multi-value list.

    'Initialize to null.
    varResult = Null

    'Build the SQL string.
    strSql = "SELECT TOP 1 " & Expr & " FROM " & Domain
    If Not IsMissing(Criteria) Then
        strSql = strSql & " WHERE " & Criteria
    End If
    If Not IsMissing(OrderClause) Then
        strSql = strSql & " ORDER BY " & OrderClause
    End If
    strSql = strSql & ";"

    'Lookup the value.
    Set db = DBEngine(0)(0)
    Set rs = db.OpenRecordset(strSql, dbOpenForwardOnly)
    If rs.RecordCount > 0 Then
        'Will be an object if multi-value field.
        If VarType(rs(0)) = vbObject Then
            Set rsMVF = rs(0).Value
            Do While Not rsMVF.EOF
                If rs(0).Type = 101 Then        'dbAttachment
                    strOut = strOut & rsMVF!FileName & strcSep
                Else
                    strOut = strOut & rsMVF![Value].Value & strcSep
                End If
                rsMVF.MoveNext
            Loop
            'Remove trailing separator.
            lngLen = Len(strOut) - Len(strcSep)
            If lngLen > 0& Then
                varResult = Left(strOut, lngLen)
            End If
            Set rsMVF = Nothing
        Else
            'Not a multi-value field: just return the value.
            varResult = rs(0)
        End If
    End If
    rs.Close

    'Assign the return value.
    ELookup = varResult

Exit_ELookup:
    Set rs = Nothing
    Set db = Nothing
    Exit Function

Err_ELookup:
    MsgBox Err.Description, vbExclamation, "ELookup Error " & Err.Number
    Resume Exit_ELookup
End Function

I have a huge library of date functions, that I have collected over the years. Most of these are not mine

Option Compare Database   'Use database order for string comparisons
    ' Functions to demonstrate date calculations
    ' Written and developed by Thomas M. Brittell
    ' Copyright 1998; All rights reserved.

Function tb1stDateQ(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the 1st date of current Quarter
    '
    Dim intQtr   As Integer
    Dim intMonth As Integer
    Dim intYear  As Integer
    
    intYear = Year(dtmDate)
    intQtr = Int((Month(dtmDate) - 1) / 3)
    intMonth = (intQtr * 3) + 1
    tb1stDateQ = DateSerial(intYear, intMonth, 1)

End Function
Function ConvertGregorian(dtmJulianDate As Long)
    '
    'Warning dtmJulianDate must be a valid date
    '
    'Return the 1st date of current Quarter
    '
    ConvertGregorian = DateSerial(1900 + Int(dtmJulianDate / 1000), 1, dtmJulianDate Mod 1000)
           
End Function
Function Convert2Julian(dtmDate As Date)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Julian day number of the date provided
    '
    Dim wrkDate As Date
    Dim inDate As Date
    Dim difDate As Date
    
    inDate = Format(dtmDate, "mm / dd /yyyy")
    wrkDate = DateSerial(Year(inDate) - 1, 12, 31)
    
    Convert2Julian = Format(inDate - wrkDate, "000")
    
End Function


Function tb1stDateW(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Weekday of specified date
    '
    Dim intDayCnt As Integer

    intDayCnt = WeekDay(dtmDate, 1) - 1
    tb1stDateW = DateAdd("d", -intDayCnt, dtmDate)

End Function

Function tb1stDayM(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the First day of provided month
    '
    Dim wrkDate    As Variant
    Dim intMonth   As Integer
    Dim intYear    As Integer
    Dim intDayCnt  As Integer
    
    intMonth = Month(dtmDate)
    intYear = Year(dtmDate)
    wrkDate = DateSerial(intYear, intMonth, 1)
    intDayCnt = WeekDay(wrkDate)
    
    tb1stDayM = tbStrDay(intDayCnt)
 
End Function
Function tb1stMonday(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the First Monday of provided month
    '
    Dim wrkDate    As Variant
    Dim intMonth   As Integer
    Dim intYear    As Integer
    Dim intDay     As Integer
    Dim intDayCnt  As Integer
    Dim intDiff    As Integer
    
    intMonth = Month(dtmDate)
    intYear = Year(dtmDate)
    
    'get first date in month
    wrkDate = DateSerial(intYear, intMonth, 1)
  
    'get the day of week first day is on
    intDayCnt = WeekDay(wrkDate, 1)
    
    'compute number of days to add to next monday
    If intDayCnt <> 2 Then
        If intDayCnt = 1 Then
            intDiff = 1
        Else
            intDiff = (7 - intDayCnt + 2)
        End If
    Else
        intDiff = 0
    End If
   
    wrkDate = DateAdd("d", intDiff, wrkDate)
    
    tb1stMonday = wrkDate

End Function

Function tb1stDayY(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the First day of the year of provided date
    '
    Dim wrkDate    As Variant
    Dim intYear    As Integer
    Dim intDayCnt  As Integer
    
    intYear = Year(dtmDate)
    wrkDate = DateSerial(intYear, 1, 1)
    intDayCnt = WeekDay(wrkDate)
    tb1stDayY = tbStrDay(intDayCnt)

End Function

Function tb1stWrkDateM(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the 1st work day of the provided Month
    '
    Dim wrkDate  As Variant
    Dim intYear  As Integer
    Dim intMonth As Integer
    Dim intDayCnt  As Integer

    intYear = Year(dtmDate)
    intMonth = Month(dtmDate)
    wrkDate = DateSerial(intYear, intMonth, 1)
    intDayCnt = WeekDay(wrkDate, 1)
    
    If intDayCnt = 1 Then
        'If Sunday Add 1 to work date
        wrkDate = DateAdd("d", 1, wrkDate)
    ElseIf intDayCnt = 7 Then
        'If Saturday add 2 to work date
        wrkDate = DateAdd("d", 2, wrkDate)
    End If

    tb1stWrkDateM = wrkDate

End Function

Function tb1stWrkDateW(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return a date of the 1st Monday of provided week
    '
    Dim wrkDate   As Variant
    Dim intDayCnt As Integer

    intDayCnt = WeekDay(dtmDate, 1)
    
    If intDayCnt = 1 Then
        wrkDate = DateAdd("d", 1, dtmDate)
    ElseIf intDayCnt > 2 Then
        intDayCnt = intDayCnt - 2
        wrkDate = DateAdd("d", -intDayCnt, dtmDate)
    Else
        wrkDate = dtmDate
    End If

    tb1stWrkDateW = wrkDate

End Function

Function tbDayCountNoHW(varTable, varCol, dtmStartDate, dtmEndDate, varSelectCol, varSelectCd) As Integer
    '
    'Warning dtmStartDate and dtmEndDate must be a valid dates
    '
    'Calculate the difference of the provided dates with no Holidays or weekends included
    '
    'varTable     - Holiday table to use for calculation of count
    'varCol       - Date column name
    'dtmStartDate - starting date inclusive for count
    'dtmEndDate   - ending date inclusive for count
    'varSelectCol - Column to check if sub set of holidays are required.
    '               such as counting only paid holidays
    'varSelectCd  - Code to look for in varSelectCol for sub set of holiday
    '
    Dim strStartDt       As Variant
    Dim strEndDt         As Variant
    Dim intDayCnt        As Integer
    Dim intHolCnt        As Integer
    Dim intSatSunCnt     As Integer
    Dim intYear          As Integer
    Dim strHoldayTableNm As String
    
    strStartDt = Forms![frmTestDateFunctions].StartDt
    strEndDt = Forms![frmTestDateFunctions].EndDt
    
    'Get the total day count
    intDayCnt = tbDayDiff(strStartDt, strEndDt)
    
    'Get the Saturday & Sunday Count
    intSatSunCnt = tbSatSunCount(strStartDt, strEndDt)
    
    'Get the Holiday Count
    intYear = Year(strStartDt)
    strHoldayTableNm = LTrim(Str(intYear) & "HolidayRef")
    intHolCnt = tbHolidayCount(strHoldayTableNm, "HolidayDate", strStartDt, strEndDt, varSelectCol, varSelectCd)
    
    tbDayCountNoHW = intDayCnt - intSatSunCnt - intHolCnt

Exit_tbDayCountNoHW:
    Set rstHoliday = Nothing
    Set dbs = Nothing
    Exit Function

Err_tbDayCountNoHW:
    MsgBox "Error #:" & Err & "; " & Error(Err)
    GoTo Exit_tbDayCountNoHW

End Function

Function tbDayDiff(dtmStartDate, dtmEndDate)
    '
    'Warning dtmStartDate and dtmEndDate must be a valid dates
    '
    'Calculate the difference between the provided dates
    '
    
    tbDayDiff = DateDiff("d", dtmStartDate, dtmEndDate)

End Function

Function tbDayOfW(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Day of provided week
    '
    Dim intDayCnt As Integer

    intDayCnt = WeekDay(dtmDate)
    tbDayOfW = tbStrDay(intDayCnt)

End Function
Function tbDaysInMonth(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Number of days in provided month
    '
    Dim wrkDate1 As Variant
    Dim wrkDate2 As Variant

    'Get first day  of month to calculate
    wrkDate1 = DateSerial(Year(dtmDate), Month(dtmDate), 1)
    
    'Get first day of next month
    wrkDate2 = DateAdd("m", 1, wrkDate1)
    
    tbDaysInMonth = DateDiff("d", wrkDate1, wrkDate2)

End Function

Function tbHolidayCount(varTable, varCol, dtmStartDate, dtmEndDate, varSelectCol, varSelectCd) As Integer
    '
    'Warning dtmDate must be a valid date
    '
    'Return number of holidays between dates provided
    '
    'varTable     - Holiday to use for calculation of count
    'varCol       - Date column name
    'dtmStartDate - starting date inclusive for count
    'dtmEndDate   - ending date inclusive for count
    'varSelectCol - Column to check if sub set of holidays are required.
    '               such as counting only paid holidays
    'varSelectCd  - Code to look for in varSelectCol for sub set of holiday
    
    Dim dbs As Database
    Dim rstHoliday As Recordset
    Dim strSQL As String
    Dim strOldFilter As String
    Dim RecCnt As Integer

    On Error GoTo Err_tbHolidayCount
    
    Set dbs = DBEngine.Workspaces(0).Databases(0)
            
    strSQL = "SELECT Count([" & varTable & "].[" & varCol & "]) AS HolCnt"
    strSQL = strSQL & " FROM " & varTable
    strSQL = strSQL & " WHERE (((([" & varTable & "].[" & varCol & "]"
    strSQL = strSQL & ")) BETWEEN #" & dtmStartDate & "# AND #" & dtmEndDate & "# ))"
    
    If varSelectCol <> "" Then
        strSQL = strSQL & " AND [" & varTable & "].[" & varSelectCol
        strSQL = strSQL & "]=" & "'" & varSelectCd & "'"
    End If
    
    Set rstHoliday = dbs.OpenRecordset(strSQL)
    RecCnt = rstHoliday.HolCnt
    rstHoliday.Close
    
Exit_tbHolidayCount:
    tbHolidayCount = RecCnt
    Exit Function
    
Err_tbHolidayCount:
    MsgBox "Error #:" & Err & "; " & Error(Err)
    Resume Exit_tbHolidayCount

End Function
Function tbIsLeapYr(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Test if the date's year a leap year
    '
    Dim varYear As Variant

    varYear = Year(dtmDate)
   
    tbIsLeapYr = (Day(DateSerial(varYear, 2, 28) + 1) = 29)

End Function

Function tbLastDateM(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last date of provided month
    '
    tbLastDateM = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)

End Function

Function tbLastDateQ(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the last date of current Quarter
    '
    Dim wrkDate  As Variant
    Dim intQtr   As Integer
    Dim intMonth As Integer
    Dim intYear  As Integer
    
    intYear = Year(dtmDate)
    intQtr = Int((Month(dtmDate) - 1) / 3)
    intMonth = (intQtr * 3) + 4
  
    'get 1st day of next quarter
    wrkDate = DateSerial(intYear, intMonth, 1)
    
    tbLastDateQ = DateAdd("d", -1, wrkDate)

End Function

Function tbLastDateW(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last date of provided week
    '
    Dim intDayCnt As Integer
    
    intDayCnt = 7 - WeekDay(dtmDate, 1)
    tbLastDateW = DateAdd("d", intDayCnt, dtmDate)

End Function

Function tbLastDateY(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last date of provided year
    '
    tbLastDateY = DateSerial(Year(dtmDate), 12, 31)

End Function

Function tbLastDayM(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last day of provided Month
    '
    Dim wrkDate   As Variant
    Dim intDayCnt As Integer
    
    wrkDate = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
    intDayCnt = WeekDay(wrkDate)
    tbLastDayM = tbStrDay(intDayCnt)

End Function

Function tbLastDayQ(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last day of the Quarter that the current date is in
    '
    Dim wrkDate   As Variant
    Dim intDayCnt As Integer
    
    wrkDate = tbLastDateQ(dtmDate)
    intDayCnt = WeekDay(wrkDate)
    tbLastDayQ = tbStrDay(intDayCnt)

End Function

Function tbLastDayY(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last day of provided year
    '
    Dim wrkDate    As Variant
    Dim intDayCnt  As Integer
    Dim strWeekDay As String
    
    wrkDate = tbLastDateY(dtmDate)
    intDayCnt = WeekDay(wrkDate)
    tbLastDayY = tbStrDay(intDayCnt)

End Function

Function tbLastWrkDateM(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the last work day of provided Month
    '
    Dim wrkDate  As Variant
    Dim intDayCnt  As Integer
    
    wrkDate = tbLastDateM(dtmDate)
    intDayCnt = WeekDay(wrkDate, 1)

    If intDayCnt = 1 Then
        'If Sunday -2 from work date to back up to Friday
        wrkDate = DateAdd("d", -2, wrkDate)
    ElseIf intDayCnt = 7 Then
        'If Saturday -1 from work date to back up to Friday
        wrkDate = DateAdd("d", -1, wrkDate)
    End If

    tbLastWrkDateM = wrkDate

End Function

Function tbLastWrkDateW(dtmDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Return the Last Work day of provided week
    '
    Dim intDay  As Integer
    
    intDay = 6 - WeekDay(dtmDate, 1)
    tbLastWrkDateW = DateAdd("d", intDay, dtmDate)

End Function
Function tbSatSunCount(dtmStartDate, dtmEndDate)
    '
    'Warning dtmDate must be a valid date
    '
    'Calculate the number of Saturdays and Sundays between the provided dates
    '
    Dim SatDate       As Date
    Dim SunDate       As Date
    Dim wrkDate       As Date
    Dim stopDate      As Date
    Dim intDayCnt     As Integer
    Dim intDiff       As Integer
    Dim intSatCnt     As Integer
    Dim intSunCnt     As Integer
    
    intSatCnt = 0
    intSunCnt = 0
    
    'compute number of days to add to get to first Saturday
    'get the day of week start date is on
    intDayCnt = WeekDay(dtmStartDate, 1)
    
    If intDayCnt < 7 Then
            intDiff = (7 - intDayCnt)
    Else
        intDiff = 0

    End If
   
    'Set date for first Saturday on or after start date
    SatDate = DateAdd("d", intDiff, dtmStartDate)
    stopDate = SatDate
   
    Do While stopDate < dtmEndDate
        intSatCnt = intSatCnt + 1
        stopDate = DateAdd("d", 7, stopDate)
    Loop
    
    'compute number of days to add to get to first Sunday
    'get the day of week first date is on
    intDayCnt = WeekDay(dtmStartDate, 1)
    
    If intDayCnt <> 1 Then
            intDiff = (7 - intDayCnt + 1)
    Else
        intDiff = 0
    End If
   
    'Set date for first Sunday on or after start date
    SunDate = DateAdd("d", intDiff, dtmStartDate)
    stopDate = SunDate
   
    Do While stopDate < dtmEndDate
        intSunCnt = intSunCnt + 1
        stopDate = DateAdd("d", 7, stopDate)
    Loop
    
    tbSatSunCount = intSunCnt + intSatCnt

End Function

Function tbStrDay(intDayCnt)
    '
    'Warning intDayCnt must be a valid integer
    '
    'Return the text string of the day provided
    
    Select Case intDayCnt
    Case 1
        tbStrDay = "Sunday"
    Case 2
        tbStrDay = "Monday"
    Case 3
        tbStrDay = "Tuesday"
    Case 4
        tbStrDay = "Wednesday"
    Case 5
        tbStrDay = "Thursday"
    Case 6
        tbStrDay = "Friday"
    Case 7
        tbStrDay = "Saturday"
    End Select

End Function

Function tbValidDate(dtmDate)
    '
    'Test if provided date is valid
    '
    
    If IsEmpty(dtmDate) Then
        ' test if no date (Null)
        tbValidDate = 0
        ElseIf IsDate(dtmDate) Then
            'its valid
            tbValidDate = 1
        Else
            'its junk
            tbValidDate = 0
    End If

End Function

 

[Swi]

Thank you for sharing.

Swi

 

[VickyC]

Greetings - I really enjoyed the code MajP supplied for determining the days on which various holidays fall.

In Canada, we have 9 Statutory Holidays. It was easy to modify your code for 8 of these Stat holidays (eg: your President's Day is our Family Day, and our Thanksgiving is on the 2nd Monday in October, not the 4th Thursday in November).

The problem we always have up here in the frozen North, is getting code for one of our Stat Holidays - Good Friday. As far as I know, businesses get this date from tables, but it would be interesting if it were possible to use code to determine this date.

For what it's worth, Good Friday is always on the Friday before Easter. Here's where things get complicated. Easter is on the 1st Sunday strictly FOLLOWING the Full Moon (ouch) that occurs ON or FOLLOWING the vernal equinox. Astronomically, the vernal equinox is usually on May 21 but occurs rarely on May 20. Ecclesiastically, though, the vernal equinox is always deemed to occur on May 21, and it is this date that is used in the calculation of Easter.

Anyway - just is just a comment for anyone interested.

 

[MajP]

If I get a chance I will code the rest. The solution is here and it is in vb.

https://www.assa.org.au/edm#Calculator

So you would just calculate Easter Sunday and sub 2 days.

 

[VickyC]

Thanks for a great reference! It'll be fun to incorporate this into your code.
Vicky C.