Time calculations including networkdays and specific hours

MZalews88

New Member
Joined
Feb 16, 2019
Messages
2
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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
If I understand correctly, then I think this might do it for you

Code:
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top