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