Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' This macro runs on any value change made to worksheet
'It assumes the top left cell 'Monday' is cell B2
Dim rTotOT As Range
Dim iTot As Integer, iR As Integer, iC As Integer, iRC As Integer, iCC As Integer, _
UB1 As Integer, UB2 As Integer, iDepHr As Integer, iCurOT As Integer, iROffs As Integer, iCOffs As Integer
Dim vMonth As Variant
Dim bDepTime As Boolean
Dim colOT1hr As Collection, colOT2hr As Collection
Dim vDate As Variant
'if more than 1 cell changed (copy paste for instance) then exit
If Target.Cells.Count > 1 Then Exit Sub
' check if relevant cell has changed. The cell changed is called 'Target'
If Not Intersect(Target, Union(Range("B4:K4"), Range("B10:K10"), Range("B16:K16"), Range("B22:K22"), Range("B28:K28"))) Is Nothing Then
' is arrival or departure time changed?
bDepTime = Target.Column Mod 2
' only act on changes when both start and departure time are given
If (bDepTime And Target < Target.Offset(0, -1)) Or (Not bDepTime And Target > Target.Offset(0, 1)) Then
' if OT exists, but deptime < arr time, then clear OT
If bDepTime Then
Target.Offset(1, -1) = 0
Else
Target.Offset(1, 0) = 0
End If
Exit Sub
End If
If (bDepTime And Target > Target.Offset(0, -1)) Or (Not bDepTime And Target < Target.Offset(0, 1)) Then
'initiate two collections to keep score of 1hr and 2 hour overtime allocations
Set colOT1hr = New Collection: Set colOT2hr = New Collection
vMonth = Range("B2:K30").Value
iROffs = 1: iCOffs = 1 ' With cell B2 being Monday, offset between array and sheet is 1 column and 1 row
UB1 = UBound(vMonth, 1): UB2 = UBound(vMonth, 2)
iRC = Target.Row - iROffs: iCC = Target.Column - iCOffs
' get total OT already assigned
For iR = 4 To UB1 Step 6
For iC = 1 To UB2 Step 2
Select Case vMonth(iR, iC)
Case 1
colOT1hr.Add iR & "," & iC
Case 2
colOT2hr.Add iR & "," & iC
Case Else 'do nothing
End Select
Next iC
Next iR
'total overtime allocated
iTot = colOT1hr.Count + colOT2hr.Count * 2
'store any current OT in modified day
iCurOT = IIf(bDepTime, vMonth(iRC + 1, iCC - 1), vMonth(iRC + 1, iCC))
'check if dep < 22:00
If bDepTime Then
iDepHr = CInt(vMonth(iRC, iCC) * 24)
Else
iDepHr = CInt(vMonth(iRC, iCC + 1) * 24)
End If
'now see what OT needs to be added
iTot = iTot - iCurOT '(-current ot as this may be a change of arrival or departure time)
Select Case iTot
Case Is <= 18
Select Case iDepHr
Case Is >= 22
' too late to claim OT
Case 21
' One hour possible
'add 1 hr OT to date's OT line
If bDepTime Then
Target.Offset(1, -1) = 1
Else
Target.Offset(1, 0) = 1
End If
Case Else
' Two hours possible
'add 2 hr OT to date's OT line
If bDepTime Then
Target.Offset(1, -1) = 2
Else
Target.Offset(1, 0) = 2
End If
End Select
Case 19
Select Case iDepHr
Case Is >= 22
' too late to claim OT
Case Else
' One hour possible
'add 1 hr OT to date's OT line
If bDepTime Then
Target.Offset(1, -1) = 1
Else
Target.Offset(1, 0) = 1
End If
End Select
Case 20
Select Case iDepHr
Case Is >= 22
' too late to claim OT
Case Else
' One hour possible but need to decrease any 2hr OT
If colOT2hr.Count > 0 Then
'adjust 1st 2 hr OT to 1 hr
vDate = Split(colOT2hr(1), ",")
Cells(vDate(0) + iROffs, vDate(1) + iCOffs) = 1
'add 1 hr OT to date's OT line
If bDepTime Then
Target.Offset(1, -1) = 1
Else
Target.Offset(1, 0) = 1
End If
Else
' no OT available, all already as 1 hr
If bDepTime Then
Target.Offset(1, -1) = 0
Else
Target.Offset(1, 0) = 0
End If
End If
End Select
End Select
End If
End If
End Sub
