Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sCurrentMonth As String
Dim dCurrentTime As Double
Dim iCurrentDate As Integer
Dim rng As Range
Dim rTbl As Range
Dim rTbl2 As Range
Dim rTbl3 As Range
Dim rFound As Range
Dim bComplete As Boolean
Dim rng2 As Range, c As Range
'exit if more than one cell is selected
If Target.CountLarge > 1 Then Exit Sub
'-----DOESNT ALLOW THE DELETE OR BACKSPACE KEY TO WORK
If Not Intersect(Target, Range("A1:BM5,A6:C24,D21:BM22")) Is Nothing Then
SetOnKey xlOn
Else
SetOnKey xlOff
End If
'reset form closed flag
bClosedUserForm1 = False
'get current month and set its shift row
sCurrentMonth = Format(Date, "mmmm")
'get current home row
Set rFound = Cells.Find(What:=sCurrentMonth, LookIn:=xlFormulas, LookAt:=xlPart)
If Not rFound Is Nothing Then
nCurrentShiftRow = rFound.Row + iRowsBelowMonth
Else
MsgBox "Current month not found."
Exit Sub
End If
'get current system time
dCurrentTime = TimeValue(Now)
'get current day number
iCurrentDate = Day(Date)
'get current day column - because the date columns are merged it returns the first column of the merge
Set rTbl = Range("D4:BM4")
Set rFound = rTbl.Find(What:=iCurrentDate, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not rFound Is Nothing Then
'get shift "D" = 06:00 to 18:00 or "N" = 18:00 to 06:00
'Original Line>>>>>>If Not dCurrentTime > 0.75 And Not dCurrentTime < 0.25 Then
If Not dCurrentTime > 0.73 And Not dCurrentTime < 0.23 Then
nTargetColumn = rFound.Column
Else
If dCurrentTime <= 0.23 Then
nTargetColumn = rFound.Column - 1 'must be midnight to 06:00 on previous date "N"
ElseIf dCurrentTime > 0.73 Then
nTargetColumn = rFound.Column + 1 'must be 18:00 to midnight on current date "N"
End If
End If
Else
MsgBox "Current date not found.", vbInformation, "Palletiser Operator"
Exit Sub
End If
'ensure only current date column and rows 5 to 19 can be processed
If Target.Column = nTargetColumn Then
If Not Target.Row > nCurrentShiftRow + iNumOfCheckRows + 1 And Not Target.Row < nCurrentShiftRow + 1 Then
Application.EnableEvents = False
'unprotect sheet to clear cell colours caused by previous missing entry
UnprotectTheActiveSheet
Set rTbl2 = Range(Cells(nCurrentShiftRow, nTargetColumn), Cells(nCurrentShiftRow + iNumOfCheckRows, nTargetColumn))
rTbl2.Interior.Color = xlNone
'ensure any remaining colours are cleared if shift changes
Set rTbl3 = Range(Cells(nCurrentShiftRow, nTargetColumn - 1), Cells(nCurrentShiftRow + iNumOfCheckRows, nTargetColumn - 1))
rTbl3.Interior.Color = xlNone
'check 'Initials' row has been selected
If Target.Row = nCurrentShiftRow + iNumOfCheckRows + 1 Then
'initialise flag
bComplete = True
'check all required current shift cells have been completed
'if incomplete, identify cell, send user message and exit safely
For Each rng In rTbl2
If rng = "" Then
Cells(nCurrentShiftRow, nTargetColumn).Select
Cells(nCurrentShiftRow, nTargetColumn).Interior.Color = RGB(155, 194, 230)
rng.Interior.Color = RGB(255, 0, 0)
ProtectTheActiveSheet
Application.EnableEvents = True
MsgBox "Please complete where highlighted.", vbInformation, "Palletiser Operator"
bComplete = False
rng.Select
Exit Sub
End If
Next rng
'call initials form if all required entries are complete
If bComplete Then Call DisplayUserForm1ForSheetsThatNeedInitialsFromUserForm(Target)
'reprotect wsheet
ProtectTheActiveSheet
End If
Application.EnableEvents = True
End If
Else
'if user selects a non current date when initials form is not loaded
If Not bClosedUserForm1 Then
ActiveWindow.ScrollRow = nCurrentShiftRow - 2
Cells(nCurrentShiftRow, nTargetColumn).Select
UnprotectTheActiveSheet
Cells(nCurrentShiftRow, nTargetColumn).Interior.Color = RGB(255, 0, 255)
ProtectTheActiveSheet
MsgBox "Please select the current date and shift column indicated.", vbInformation, "Palletiser Operator"
ActiveCell.Offset(1, 0).Select
End If
End If
Application.EnableEvents = True
'----- IF Y ENTEREND IN THE MONTHLY CHECK THEN THE REST OF THE MONTH FILL WITH C
Set rng2 = Intersect(Target, Range("D23:BL23"))
If Not rng2 Is Nothing Then
For Each c In rng2
If UCase(c.Value) = "Y" Then
Application.EnableEvents = False
Range(Cells(23, c.Column + 1), Cells(23, "BM")) = "C"
Application.EnableEvents = True
End If
Next
End If
End Sub
