calculate finishdate and time considering offdays and holidays - ms-access

Question

I'm not a VBA expert. I simply copy from the net and try to utilize in my program. however, below is my codes. I'm trying to calculate a finish date considering offdays, but the issue is sometime the time required is less than one day in that case it is calculating as 1 day. How can I calculate it by hours. Suppose if the startdate is 1-jan-2019 6:00 am and the required time to produce is 6 hours than the finish time should be 1-jan-2019 12:00pm
Public Function AddFinishDate(StartDate As Date, ReqDays As Double, FriOff As Boolean) As Date
Dim rst As Recordset
Dim db As Database
Dim FinishDate As Date
Dim icount As Integer
On Error GoTo errhandlers:
Set db = CurrentDb
Set rst = db.OpenRecordset("tblHoliday", dbOpenSnapshot)
icount = 0
FinishDate = StartDate
Do While icount < ReqDays
FinishDate = FinishDate + 1
If Weekday(FinishDate, vbSaturday) <> 7 Or FriOff = False Then
rst.FindFirst "(HolidayDate)= #" & FinishDate & "#"
If rst.NoMatch Then
icount = icount + 1
End If
End If
Loop
AddFinishDate = FinishDate
exit_errhandlers:
rst.Close
Set rst = Nothing
Set db = Nothing
AddFinishDate = FinishDate
Exit Function
errhandlers:
MsgBox Err.Description, vbExclamation
Resume Next
End Function
Private Sub Command53_Click()
Dim dbs As DAO.Database
Set dbs = CurrentDb()
dbs.Execute "UPDATE BalFitToFabricate " & "SET used = false , startdate ="""",finishdate ="""";"
Me.Refresh
End Sub
Private Sub Command71_Click()
Dim dbs As DAO.Database, Initrst, rst, rst2 As DAO.Recordset
Dim strSQL
Dim ClientsTableQuery, SalesRepList As TableDef
Dim DataB As Database
Dim ClientQD As QueryDef
Dim rstClient As DAO.Recordset
Dim DurationTotal, Counter, i As Integer
Dim LowDate1, LowDate2 As Date
Dim tmpArray(10), FieldArray(10), TempDate1, TempDate2 As Date
Dim TotalDailyHrs, TempDailyHours As Integer
Dim FirstTimeIn As Boolean
FirstTimeIn = False
TotalDailyHrs = Forms("BalFitToFabricate").Text49.Value
TempDailyHours = TotalDailyHrs
Set dbs = CurrentDb()
ClientsTableQuery = "BalFitToFabricate"
'strSQL = "Select * from Client_Table"
Set DataB = CurrentDb()
Set rstClient = DataB.OpenRecordset(ClientsTableQuery)
rstClient.MoveFirst
Counter = 0
Set Initrst = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate;")
'Set rst = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate;")
Set rst = dbs.OpenRecordset("SELECT * FROM (SELECT * FROM (SELECT * FROM BalFitToFabricate WHERE Used = false)) WHERE FinishDate = (select min(FinishDate) from BalFitToFabricate where Used = false);")
Set rst2 = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate WHERE isnull(StartDate) order by NULLSORTER,Req_Del_Date,Priority;")
'Autonumrst.Requery
'MsgBox Initrst.RecordCount & " " & rst.RecordCount & " " & rst2.RecordCount
'First Loop
Do Until rstClient.EOF = True
If TempDailyHours <= TotalDailyHrs Then
'Autonumrst.Requery
'If FirstTimeIn = False Then
' TotalDailyHrs = TotalDailyHrs - TempDailyHours
'End If
TempDailyHours = Initrst![CreqHours]
Dim Autonumrst, Valuesrst As DAO.Recordset
Dim strSQL2, strSQL3 As String
'strSQL2 = "SELECT [Crew Hours] FROM Table2 where AutoNum = " & Initrst!Autonum & "and used = false;"
strSQL2 = "SELECT [CreqHours] FROM Table2 where Used = False;"
strSQL3 = "SELECT * FROM Table2 where Used = False;"
Set Autonumrst = CurrentDb.OpenRecordset(strSQL2)
Set Valuesrst = CurrentDb.OpenRecordset(strSQL3)
' new code:
'Stopped 2 lines
'TempDailyHours = Autonumrst![Crew Hours]
'Autonumrst.Requery
'Autonumrst.Close
'TempDailyHours = dbs.Execute "select BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE Autonum = " & Initrst!Autonum & ";"
TotalDailyHrs = TotalDailyHrs - TempDailyHours
If TotalDailyHrs > 0 Then
TempDate1 = Format([Forms]![BalFitToFabricate]![Text51].Value, "mm-dd-yyyy")
'TempDate1 = [Forms]![BalFitToFabricate]![Text68].Value
dbs.Execute "UPDATE BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE ID = " & Initrst!ID & ";"
TempDate2 = AddFinishDate(Format(TempDate1, "mm-dd-yyyy"), Initrst!ReqDays, Me.FridayOffCheckBox2)
dbs.Execute "UPDATE BalFitToFabricate " & "SET finishdate = #" & TempDate2 & "# WHERE ID = " & Initrst!ID & ";"
'TempDate1 = strSQL59 + (strSQL22 / strSQL57)
'TempDate2 = Format(TempDate1 + (Valuesrst![Total_Req_Manhours] / Valuesrst![Crew Hours]), "dd-mm-yyyy")
'dbs.Execute "UPDATE BalFitToFabricate " & "SET Finishdate = #" & TempDate2 & "# WHERE Autonum = " & Initrst!AutoNum & ";"
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = True WHERE ID = " & Initrst!ID & ";"
End If
Initrst.MoveNext
'Autonumrst.MoveNext
Else
GoTo ExitLoop1
End If
Loop
ExitLoop1:
'MsgBox rst!Ord_No & " " & rst2!Ord_No
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = False;"
TotalDailyHrs = Forms("BalFitToFabricate").Text49.Value
TempDailyHours = TotalDailyHrs
'Second Loop
Do Until rstClient.EOF = True
'Counter = Counter + 1
'i = rstClient!Ord_No
'If rstClient.Fields("Duration") <> "" Then
' DurationTotal = DurationTotal + rstClient.Fields("Duration")
'FieldArray(Counter) = rstClient.Fields("End")
'End If
'If DurationTotal >= 15 Then
If TempDailyHours <= TotalDailyHrs Then
'If rstClient!Used = False Then
strSQL3 = "SELECT * FROM Table2 where Finishdate is null;"
Set Valuesrst = CurrentDb.OpenRecordset(strSQL3)
Valuesrst.Requery
'Counter = rst2.RecordCount
Dim temp22 As Integer
temp22 = rst.RecordCount
rst.Requery
rst2.Requery
If rst2.RecordCount <= 0 Then
GoTo ExitLoop2
End If
LowDate1 = "#" & rst!FinishDate & "#"
'LowDate2 = "#" & Valuesrst!finishdate & "#"
'End If
''Set dbs = OpenDatabase("database41.accdb")
TempDate1 = Format(rst!FinishDate, "mm-dd-yyyy")
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = true WHERE ID = " & rst!ID & ";"
dbs.Execute "UPDATE BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE ID = " & rst2!ID & ";"
'TempDate1 = Format([Forms]![BalFitToFabricate]![Text59].Value + ([Forms]![BalFitToFabricate]![Text22].Value / [Forms]![BalFitToFabricate]![Text57].Value), "dd-mm-yyyy")
'TempDate1 = Format(Valuesrst![StartDate] + (Valuesrst![Total_Req_Manhours] / Valuesrst![Crew Hours]), "dd-mm-yyyy")
'dbs.Execute "UPDATE BalFitToFabricate " & "SET Finishdate = #" & TempDate1 & "# WHERE Autonum = " & Valuesrst!AutoNum & ";"
TempDate2 = AddFinishDate(Format(TempDate1, "mm-dd-yyyy"), rst!ReqDays, Me.FridayOffCheckBox2)
dbs.Execute "UPDATE BalFitToFabricate " & "SET finishdate = #" & TempDate2 & "# WHERE ID = " & rst2!ID & ";"
End If
'rstClient.MoveNext
Loop
ExitLoop2:
MsgBox "Finished Scheduling " & DurationTotal & "Time: " & Time()
rstClient.Close
[Forms]![BalFitToFabricate].Refresh
End Sub

Answer 1

This is not that easy, if you don't work round the clock. I have an old function that takes off-hours and weekends in consideration, though not holidays:
Public Function WorkhourAdd( _
ByVal datDateStart As Date, _
ByVal intHours As Integer) _
As Date
' Purpose: Add number of working hours to date datDateStart.
' Assumes: 5 working days per week. Adjust cbytWorkdaysOfWeek for other values.
' First workday is Monday.
' Weekend is up to and including Sunday.
' Limitation: Does not count for public holidays.
' May be freely used and distributed.
'
' 2011-01-15. Gustav Brock, Cactus Data ApS, Copenhagen
' Specify begin and end time of daily working hours.
Const cdatWorkTimeStart As Date = #8:00:00 AM#
Const cdatWorkTimeStop As Date = #4:00:00 PM#
Const cbytWorkdaysOfWeek As Byte = 5
Dim intCount As Integer
Dim datDateEnd As Date
datDateEnd = datDateStart
While intCount < intHours
datDateEnd = DateAdd("h", 1, datDateEnd)
If Weekday(datDateEnd, vbMonday) <= cbytWorkdaysOfWeek Then
If DateDiff("h", cdatWorkTimeStart, TimeValue(datDateEnd)) > 0 Then
If DateDiff("h", TimeValue(datDateEnd), cdatWorkTimeStop) >= 0 Then
intCount = intCount + 1
End If
End If
End If
Wend
WorkhourAdd = datDateEnd
End Function
You could modify it to check if time is within a holiday, to find finish time across holidays.