I have created a new function that I think might be useful to other people.
I am not an experienced programmer and so would welcome any thoughts on how this could be improved to be more efficient, customisable, or usable for public release.
It calculates how many office hours are between two dates and times, taking into account a list of holidays (it ignores the year of the holidays in the table).
You can set the start and finish time of your office hours at the start.
Here is the function:
And here is an example sub to run it:
I am not an experienced programmer and so would welcome any thoughts on how this could be improved to be more efficient, customisable, or usable for public release.
It calculates how many office hours are between two dates and times, taking into account a list of holidays (it ignores the year of the holidays in the table).
You can set the start and finish time of your office hours at the start.
Here is the function:
Code:
Public Function OfficeHoursCalc(date1 As Date, date2 As Date) As Integer
' Function to calculate the number of office hours between two input dates, taking into account holidays.
' Created by Trevor Lancaster - 11/04/2008
On Error GoTo error1
Dim endofday1 As Date, startofday2 As Date, dte1 As Date, dte2 As Date, starttime As Date, endtime As Date, db As DAO.Database, rs1 As DAO.Recordset, holidaystable1 As String
Dim daysdiff As Integer, hours1 As Integer, hours2 As Integer, totalhours As Integer, hoursperday As Integer, x As Integer, hols1 As Integer
'Set the variables:
starttime = "8:00:00 AM" ' Enter the time your office hours start in the morning
endtime = "5:00:00 PM" ' Enter the time your office hours finish in the afternoon
holidaystable1 = "tblDates" ' Enter the table of holiday dates, it must contain a field called "holidaydate" which lists all holidays in a short date format
'If they are round the wrong way, swap them
If date1 > date2 Then
date1 = date1 + date2
date2 = date1 - date2
date1 = date1 - date2
End If
'Calculate more variables
hoursperday = DateDiff("h", starttime, endtime)
dte1 = Format(date1, "dd,mm,yyyy")
dte2 = Format(date2, "dd,mm,yyyy")
endofday1 = dte1 + endtime
startofday2 = dte2 + starttime
hours1 = DateDiff("h", date1, endofday1)
hours2 = DateDiff("h", startofday2, date2)
'If its the same day
If DateDiff("d", endofday1, date2) = 0 Then OfficeHoursCalc = DateDiff("h", date1, date2)
'If its the next day
If DateDiff("d", endofday1, date2) = 1 Then OfficeHoursCalc = hours1 + hours2
'If its more than one day:
'Look up how many holidays, and repeat if more than 1 year between dates
For x = 1 To Year(dte2) - Year(dte1)
Set db = CurrentDb()
Set rs1 = db.OpenRecordset(holidaystable1)
rs1.MoveFirst
Do Until rs1.EOF
If DateSerial(Year(dte1), Month(rs1![holidaydate]), Day(rs1![holidaydate])) > dte1 And DateSerial(Year(dte1), Month(rs1![holidaydate]), Day(rs1![holidaydate])) < dte2 Then hols1 = hols1 + 1
If DateSerial(Year(dte2), Month(rs1![holidaydate]), Day(rs1![holidaydate])) > dte1 And DateSerial(Year(dte2), Month(rs1![holidaydate]), Day(rs1![holidaydate])) < dte2 Then hols1 = hols1 + 1
rs1.MoveNext
Loop
rs1.Close
Set rs = Nothing
Set db = Nothing
Next x
'Calculate how many days in between, then minus holidays, then calculate hours
If DateDiff("d", endofday1, date2) > 1 Then
daysdiff = DateDiff("d", dte1, dte2) - DateDiff("ww", dte1, dte2, 1) * 2 - IIf(Weekday(dte2, 1) = 7, IIf(Weekday(dte1, 1) = 7, 0, 1), IIf(Weekday(dte1, 1) = 7, -1, 0))
daysdiff = daysdiff - hols1
totalhours = ((daysdiff - 1) * hoursperday) + hours1 + hours2
OfficeHoursCalc = totalhours
End If
Exit Function
error1:
MsgBox ("There was an Error.")
OfficeHoursCalc = 0
End FunctionAnd here is an example sub to run it:
Code:
Sub testT23()
Dim d1 As Date, d2 As Date
d2 = "20/12/2007 2:00:00 PM"
d1 = "4/1/2008 4:00:00 PM"
MsgBox OfficeHoursCalc(d1, d2) & " Office Hours."
End Sub
Last edited:
