Hi
I just replied to your message
here is some code to try
it ssumes your start dates are in the range "StartRange" and the end time is in the column to the right of that. It types the hours calcs in successive cells in a column, starting at the "OutCell". Tou will need to change these addresses to suit your data
Sub calc_hours()
Dim StartRange As Range, Outcell As Range, DDiFF, CCell As Range, WDays As Long, DateVal, Addit As Boolean, Shour, Ehour
Set StartRange = Range("A1:A67")
Set Outcell = Range("F1")
For Each CCell In StartRange.Cells
DDiFF = 0
WDays = Application.WorksheetFunction.NetworkDays(CCell.Value, CCell.Offset(0, 1).Value)
'start and end on same day
If DateValue(CCell.Value) = DateValue(CCell.Offset(0, 1).Value) Then
Shour = Hour(CCell.Value)
If Shour < 6 Then Shour = 6
If Shour > 18 Then Shour = 18
Ehour = Hour(CCell.Offset(0, 1).Value)
If Ehour < 6 Then Ehour = 6
If Ehour > 18 Then Ehour = 18
DDiFF = Ehour - Shour
GoTo NextBit
End If
'start on weekday
If Weekday(CCell.Value, vbMonday) < 6 Then
Shour = Hour(CCell.Value)
If Shour < 6 Then Shour = 6
If Shour > 18 Then Shour = 18
DDiFF = DDiFF + 18 - Shour
End If
'end on weekday
If Weekday(CCell.Offset(0, 1).Value, vbMonday) < 6 Then
Ehour = Hour(CCell.Offset(0, 1).Value)
If Ehour < 6 Then Ehour = 6
If Ehour > 18 Then Ehour = 18
DDiFF = DDiFF + Ehour - 6
End If
'If Weekday(CCell.Offset(0, 1).Value, vbMonday) > 5 Then DDiFF = DDiFF + 12
'If Weekday(CCell.Value, vbMonday) > 5 And Weekday(CCell.Offset(0, 1).Value, vbMonday) > 5 Then DDiFF = DDiFF + 12
'If WDays > 2 Then DDiFF = DDiFF + 12 * (WDays - 2)
DateVal = DateValue(CCell.Value) + 1
Do While DateVal < DateValue(CCell.Offset(0, 1).Value)
If Weekday(DateVal, vbMonday) < 6 Then DDiFF = DDiFF + 12
DateVal = 1 + DateVal
Loop
NextBit:
Outcell.Value = DDiFF
Set Outcell = Outcell.Offset(1, 0)
Next CCell
End Sub
Bookmarks