Find the date/time difference between two dates excluding weekends / off work hours and returns x Days y Hrs zz Mins

Question

My working hours are Monday to Friday between 09:00 and 17:00. I have a sub that detects if a cell has been modified in Column 5 and returns the timestamp it was modified in a corresponding Cell in Column 6. My problem is, I want to Subtract the value between the delivery date in column 3 and the timestamp and return in a corresponding Cell in Column 8 a Value like "2 Days 3 Hrs 20 Mins". Any help will free me from this migraine. Thanks in advance. Below is my code so far.

Sub WorkSheet_Change(ByVal Target As Range)
Dim DeliveryDate As Date
Dim DayCount As Long
Dim EoD As Date
Dim SoD As Date
Dim StartDiff As Long
Dim EndDiff As Long
Dim TotalDiff As Long
Dim TotalHrs As Long

DayCount = 0
DeliveryDate = Cells(Target.Row, 6).Value

For x = Day(Now) + 1 To Day(DeliveryDate) - 1
D = Weekday(x)
If D <> 1 And D <> 7 Then DayCount = DayCount + 1
Next x
EoD = DateSerial(Year(Now), Month(Now), Day(Now)) + TimeSerial(17, 0, 0)
SoD = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(9, 0, 0)
StartDiff = DateDiff("n", Now, EoD)
EndDiff = DateDiff("n", SoD, DeliveryDate)
If StartDiff + EndDiff >= 480 Then
    DayCount = DayCount + 1
    TotalDiff = StartDiff + EndDiff - 480
Else
    TotalDiff = StartDiff + EndDiff
End If
If TotalDiff >= 60 Then
    TotalHrs = TotalDiff \ 60
    TotalDiff = TotalDiff Mod 60
Else
    TotalHrs = 0
End If

Application.EnableEvents = False
If Target.Column = 5 Then

If Target.Value Like "*" Then
Cells(Target.Row, 7).Value = DateTime.Now 'Timetamp
Cells(Target.Row, 8).Value = DayCount & " Business Days, " & TotalHrs & " Business Hours, " &               TotalDiff & " Business Mins Remain"
End If

If Target.Value = "" Then
Cells(Target.Row, 7).Value = ""
Me.Cells(Target.Row, 8).Value = ""
End If
Application.EnableEvents = True
End If

End Sub

Answer 1

EDIT: AT LONG LAST... a working solution! Let me know if this works!

First it finds out how many days (weekdays), then it finds out the remaining hours and minutes (SoD and EoD for Start of Day and End of Day), then if those minutes are more than one day it adds that to total days, then it finds remaining hours by dividing out the minutes, then it leaves the remainder in minutes. Let me know if this works.

EDIT: Added a check for if ReqDate is on the weekend.

Sub WorkSheet_Change(ByVal Target As Range)

Dim DeliveryDate As Date
Dim ReqDate As Date
Dim MonDate As Date
Dim DayCount As Long
Dim EoD As Date
Dim SoD As Date
Dim NextSoD As Date
Dim StartDiff As Long
Dim EndDiff As Long
Dim TotalDiff As Long
Dim TotalHrs As Long

DayCount = 0

MonDate = Cells(1, 8).Value

'Application.EnableEvents = False
If Target.Column = 6 Then

If Target.Value Like "*" Then
Cells(Target.Row, 7).Value = DateTime.Now 'Timetamp
End If

If Target.Value = "" Then
Cells(Target.Row, 7).Value = ""
Me.Cells(Target.Row, 8).Value = ""
End If

Select Case ActiveSheet.Name
    Case "Monday"
        DeliveryDate = MonDate
    Case "Tuesday"
        DeliveryDate = DateAdd("d", 1, MonDate)
    Case "Wednesday"
        DeliveryDate = DateAdd("d", 2, MonDate)
    Case "Thursday"
        DeliveryDate = DateAdd("d", 3, MonDate)
    Case "Friday"
        DeliveryDate = DateAdd("d", 4, MonDate)
    Case Else
        MsgBox "Name of Sheet is not a proper Day of Week"
        Exit Sub
End Select

Select Case Cells(Target.Row, 3).Value
    Case 1
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(9, 30, 0)
    Case 2
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(10, 30, 0)
    Case 3
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(11, 30, 0)
    Case 4
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(12, 30, 0)
    Case 5
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(13, 30, 0)
    Case 6
        DeliveryDate = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(14, 30, 0)
    Case Else
        MsgBox "Delivery Window is not a valid number 1-6"
        Exit Sub
End Select

ReqDate = Cells(Target.Row, 7).Value

If ReqDate < DateSerial(Year(ReqDate), Month(ReqDate), Day(ReqDate)) + TimeSerial(9, 0, 0) Then
    ReqDate = DateSerial(Year(ReqDate), Month(ReqDate), Day(ReqDate)) + TimeSerial(9, 0, 0)
ElseIf ReqDate > DateSerial(Year(ReqDate), Month(ReqDate), Day(ReqDate)) + TimeSerial(17, 0, 0) Then
    ReqDate = DateSerial(Year(ReqDate), Month(ReqDate), Day(ReqDate) + 1) + TimeSerial(9, 0, 0)
Else
End If

Select Case Weekday(ReqDate)
    Case 7
        ReqDate = DateAdd("d", 2, ReqDate)
    Case 1
        ReqDate = DateAdd("d", 1, ReqDate)
    Case Else
End Select

Cells(Target.Row, 8).Value = DeliveryDate

    EoD = DateSerial(Year(ReqDate), Month(ReqDate), Day(ReqDate)) + TimeSerial(17, 0, 0)
    SoD = DateSerial(Year(DeliveryDate), Month(DeliveryDate), Day(DeliveryDate)) + TimeSerial(9, 0, 0)
    NextSoD = DateAdd("h", 16, EoD)
    DayCount = Application.WorksheetFunction.NetworkDays(NextSoD, SoD) - 1
    StartDiff = DateDiff("n", ReqDate, EoD)
    EndDiff = DateDiff("n", SoD, DeliveryDate)
    If StartDiff + EndDiff >= 480 Then
        DayCount = DayCount + 1
        TotalDiff = StartDiff + EndDiff - 480
    Else
        TotalDiff = StartDiff + EndDiff
    End If
    If TotalDiff >= 60 Then
        TotalHrs = TotalDiff \ 60
        TotalDiff = TotalDiff Mod 60
    Else
        TotalHrs = 0
    End If
If DayCount < 0 Or TotalHrs < 0 Or TotalDiff < 0 Then
    Cells(Target.Row, 9).Value = "Error: Delivery Date is BEFORE requested date"
    Else
    Cells(Target.Row, 9).Value = DayCount & " Business Days, " & TotalHrs & " Business Hours, " & TotalDiff & " Business Mins Remain"
End If
'Application.EnableEvents = True
End If

End Sub