There is some hebrew in it but don't pay attention to it. :-)
Option Explicit
Dim ShabbosRange As Range
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Worksheet_Change_Exit
'Make sure we are only in the shifts range
If (Target.Cells.Column = 4 And Target.Cells.Column <= 12 _
And Target.Cells.Row = 5 And Target.Cells.Row <= 52) Or _
(Target.Cells.Column = 17 And Target.Cells.Column <= 25 _
And Target.Cells.Row = 5 And Target.Cells.Row <= 49) Then
'Check for double shifts on same row
If Check_Doubles(Target) = True Then
MsgBox "!אין להכניס ערכים כפולים", vbCritical, "ערכים כפולים"
Target = ""
End If
'Count Shabbos shifts and edit cells
ShabbosRange = SetShabbosRange(Target)
End If
Worksheet_Change_Exit:
End Sub
Private Function Check_Doubles(ByVal PresentRange As Range) As Boolean
Dim c As Range
Dim count As Integer
count = 0
If PresentRange = "" Then
GoTo con:
End If
Select Case PresentRange.Cells.Column
Case 4 To 12
GoTo CheckFirst
Case 17 To 25
GoTo CheckSecond
End Select
CheckFirst:
For Each c I
Worksheets("Sheet1").Range(Sheet1.Cells(PresentRan ge.Cells.Row, "D")
Sheet1.Cells(PresentRange.Cells.Row, "L"))
If c.Value = PresentRange.Value Then
count = count + 1
End If
Next c
GoTo con
CheckSecond:
For Each c I
Worksheets("Sheet1").Range(Sheet1.Cells(PresentRan ge.Cells.Row, "Q")
Sheet1.Cells(PresentRange.Cells.Row, "Y"))
If c.Value = PresentRange.Value Then
count = count + 1
End If
Next c
con:
If count 1 Then
Check_Doubles = True
Else
Check_Doubles = False
End If
End Function
Private Function SetShabbosRange(ByVal PresentRange As Range) A
Integer
Dim c, WorkerRange As Range
Dim i As Integer
Select Case PresentRange.Cells.Column
Case 4, 17
Set ShabbosRange = Sheet1.Range("AH20")
Set WorkerRange = Sheet1.Range("D5:D52,Q5:Q49")
i = 1
Case 5, 18
Set ShabbosRange = Sheet1.Range("AH21")
Set WorkerRange = Sheet1.Range("E5:E52,R5:R49")
i = 2
Case 6, 19
Set ShabbosRange = Sheet1.Range("AH22")
Set WorkerRange = Sheet1.Range("F5:F52,S5:S49")
i = 3
Case 7, 20
Set ShabbosRange = Sheet1.Range("AH23")
Set WorkerRange = Sheet1.Range("G5:G52,T5:T49")
i = 4
Case 8, 21
Set ShabbosRange = Sheet1.Range("AH24")
Set WorkerRange = Sheet1.Range("H5:H52,U5:U49")
i = 5
Case 9, 22
Set ShabbosRange = Sheet1.Range("AH25")
Set WorkerRange = Sheet1.Range("I5:I52,V5:V49")
i = 6
Case 10, 23
Set ShabbosRange = Sheet1.Range("AH26")
Set WorkerRange = Sheet1.Range("J5:J52,W5:W49")
i = 7
Case 11, 24
Set ShabbosRange = Sheet1.Range("AH27")
Set WorkerRange = Sheet1.Range("K5:K52,X5:X9")
i = 8
Case 12, 25
Set ShabbosRange = Sheet1.Range("AH28")
Set WorkerRange = Sheet1.Range("L5:L52,Y5:Y49")
i = 9
End Select
SetShabbosRange = CountShabbos(WorkerRange, i)
End Function
Private Function CountShabbos(ByVal WorkerRange As Range, ByVal i A
Integer) As Integer
Dim count As Integer
Dim c As Range
count = 0
For Each c In WorkerRange
If c.Cells.Value = "" Then
GoTo con_func
End If
If Sheet1.Cells(c.Cells.Row, c.Cells.Column - i) = "ש" O
_
Sheet1.Cells(c.Cells.Row - 1, c.Cells.Column - i) = "ש
Or _
Sheet1.Cells(c.Cells.Row - 2, c.Cells.Column - i) = "ש
Then
count = count + 1
End If
con_func:
Next c
CountShabbos = count
End Functio
--
Message posted from
http://www.ExcelForum.com