Time calculations including networkdays and specific hours

[MZalews88]

Hello All!

This is my 1st post here. After looong brainstorming I decided to try forums with my issue...
I need to create a formula in VBA which would substract dates (that is easy part).

But...there are few contidions:
1) I need to include only working days (worksheetfunction.networkdays)
2) I need to remember, that every full day is 8.50 hours long
3) 1st day finishes at 5:00:00 PM
4) last day starts at 8:30:00 AM

What I need to is to count the total time of an order from when it is in the system until it's completed, there're few steps:
1) count worksheetfunction.networkdays, substract 2 (1st and last day)
2) count number of hours for 1st day for example: 5:00:00 PM - 1/23/2019 10:38:51 AM(this is the format in file)
3) count number of hours for last day for exampl: 1/30/2019 12:59:32 PM - 8:30:00
4) summarise 1st day hours + last day hours + full days hours (8.5 hour per day as mentioned).

This is what I was trying to do...it works if there're no integers, for example 34 hours or so, but in case of 8.5 hour I'm struggling to add it, to the sum of the 1st and last day...any help would be much appreciated.

Code(it's not finished, I afraid not even in half):

Function TotalHours(Start As Date, EndT As Date)
Dim FirstDay, LastDay As Long


NetworkD = WorksheetFunction.NetworkDays(Start, EndT) - 2
FullDays = NetworkD * 8.5






If (TimeValue(Start) > TimeValue("5:00:00 PM")) Then StartDiff = 0 Else StartDiff = TimeValue("5:00:00 PM") - TimeValue(Start)


'MsgBox Hour(StartDiff) & ":" & Minute(StartDiff) & ":" & Second(StartDiff)


If (TimeValue("8:30:00 AM") < TimeValue(EndT)) Then EndDiff = 0 Else EndDiff = TimeValue(EndT) - TimeValue("8:30:00 AM")


'MsgBox Hour(EndDiff) & ":" & Minute(EndDiff) & ":" & Second(EndDiff)

Select Case NetworkD


Case Is >= 2

FirstAndLast = Left(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 2)


Total = FullDays + FirstAndLast & ":" & Mid(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 4, 2) _
& ":" & Right(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 2)


TotalHours = Total


Case Is = 1


'FirstAndLast = Left(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 2)


'Total = FullDays + FirstAndLast & ":" & Mid(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 4, 2) _
& ":" & Right(Format(Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff), "HH:MM:SS"), 2)


'TotalHours = Total


'MsgBox Hour(StartDiff + EndDiff) & ":" & Minute(StartDiff + EndDiff) & ":" & Second(StartDiff + EndDiff)
'MsgBox TimeSerial(8, 30, 0)
'MsgBox TimeValue(FullDays)




Case Else


TotalHours = ""


End Select






End Function

 

[RSpin]

If I understand correctly, then I think this might do it for you

Function TotalHours(Start As Date, EndT As Date) As Double


Dim SingleDay As Integer
Dim HoursWorked As Double


HoursWorked = 0
For SingleDay = 0 To DateDiff("d", Start, EndT)
    If Weekday(DateAdd("d", SingleDay, Start), vbUseSystemDayOfWeek) <> 1 And Weekday(DateAdd("d", SingleDay, Start), vbUseSystemDayOfWeek) <> 7 Then
        If SingleDay = 0 Then
            If TimeValue(Start) < TimeValue("5:00:00 PM") Then
                If TimeValue(Start) < TimeValue("8:30:00 AM") Then
                    HoursWorked = HoursWorked + 8.5
                Else
                    HoursWorked = HoursWorked + (TimeValue("5:00:00 PM") - TimeValue(Start))
                End If
            End If
        Else
            If SingleDay = DateDiff("d", Start, EndT) Then
                If TimeValue(EndT) > TimeValue("8:30:00 AM") Then
                    If TimeValue(EndT) > TimeValue("5:00:00 PM") Then
                        HoursWorked = HoursWorked + 8.5
                    Else
                        HoursWorked = HoursWorked + (TimeValue("5:00:00 PM") - TimeValue(EndT))
                    End If
                End If
            Else
                HoursWorked = HoursWorked + 8.5
            End If
        End If
    End If
Next SingleDay
TotalHours = HoursWorked


End Function

 

[MZalews88]

Hi RSpin!

Thanks for your answer

To be honest...I tried 2nd approach yday and I came up with the following code (it works!)

Function TotalHours(Start As Date, EndT As Date)


Dim Networkd As Long
Dim FirstDaySeconds, LastDaySeconds, SameDaySeconds, FullDays, Hours, Hours0, FirstTest As Double
Dim WS_Holiday As Worksheet
Dim R_Holiday As Range
Dim FirstDayHours, LastDayHours, SameDayHours As Date


Set WS_Holiday = Worksheets("Holiday")




'if you wish to add any holiday to the sheet, please remember to update the range
Set R_Holiday = WS_Holiday.Range("A2:A32")




'networkdays function to include only working days
Networkd = WorksheetFunction.NetworkDays(Start, EndT, R_Holiday) - 2




Select Case Networkd


Case Is >= 1
'in case of 1st day we measure time from when order came in until 5 pm, if order enters after 5pm we put 0
'in case of last day we measure tim from 8:30 am until order is completed
FullDays = Networkd * 8.5 * 3600
If (TimeValue(Start) >= TimeValue(#5:00:00 PM#)) Then FirstDayHours = 0 Else FirstDayHours = TimeValue(#5:00:00 PM#) - TimeValue(Start)


FirstDaySeconds = Hour(FirstDayHours) * 3600 + Minute(FirstDayHours) * 60 + Second(FirstDayHours)


LastDayHours = TimeValue(EndT) - TimeValue(#8:30:00 AM#)
LastDaySeconds = Hour(LastDayHours) * 3600 + Minute(LastDayHours) * 60 + Second(LastDayHours)


Hours = (FirstDaySeconds + LastDaySeconds + FullDays) / 86400


TotalHours = Application.WorksheetFunction.Text(Hours, "[h]:mm:ss")

Case Is = 0


FullDays = 0


If (TimeValue(Start) >= TimeValue(#5:00:00 PM#)) Then FirstDayHours = 0 Else FirstDayHours = TimeValue(#5:00:00 PM#) - TimeValue(Start)


FirstDaySeconds = Hour(FirstDayHours) * 3600 + Minute(FirstDayHours) * 60 + Second(FirstDayHours)


LastDayHours = TimeValue(EndT) - TimeValue(#8:30:00 AM#)
LastDaySeconds = Hour(LastDayHours) * 3600 + Minute(LastDayHours) * 60 + Second(LastDayHours)


Hours = (FirstDaySeconds + LastDaySeconds + FullDays) / 86400


TotalHours = Application.WorksheetFunction.Text(Hours, "[h]:mm:ss")

Case Is <= -1


SameDayHours = TimeValue(EndT) - TimeValue(Start)

SameDaySeconds = Hour(SameDayHours) * 3600 + Minute(SameDayHours) * 60 + Second(SameDayHours)


Hours0 = SameDaySeconds / 86400


TotalHours = Application.WorksheetFunction.Text(Hours0, "[h]:mm:ss")


End Select

Cheers!
Michal

 

[RSpin]

I'm glad it all worked out for you.