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

and?

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

"Ben_2004 " wrote in message
...
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 In
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 In
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) As
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 As
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) = "ù" Or
_
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 Function


---
Message posted from http://www.ExcelForum.com/

Bob? and what? Why do I only get my coded warning if I put duplicat
values into 2 cells, one at a time? But if I paste and copy, I don'
get any warning? In other words, if I paste and copy duplicate value
into a few cells at a time, the values stay in cells and m
"Check_Duplicates" function doesn't get triggered?

--
Message posted from http://www.ExcelForum.com

Ben,

Bob? and what? Why do I only get my coded warning if I put duplicate
values into 2 cells, one at a time? But if I paste and copy, I don't
get any warning? In other words, if I paste and copy duplicate values
into a few cells at a time, the values stay in cells and my
"Check_Duplicates" function doesn't get triggered??

Bob was alluding to the fact that you didn't post a question. So it was
hard to figure out what you were asking. <g

I think I know what may be happening. The Target parameter holds a
reference to the cell or cells that changed. If you are pasting values in
for multiple cells, Target will point to a range, not a single cell. So
Target.Cells.Row and .Column may not give you what you are expecting. For
example:

?Range("A1:B10").Cells.Row
1
?Range("A1:B10").Cells.Column
1

So even though B10 is in the range, you are only getting row=1 and column=1.

You may want to use the Intersect method to determine if any cell in Target
is in your desired range. But your other code would have to change as well
to account for the possibility that Target may be a range containing
multiple cells.

--
Regards,

Jake Marx
MS MVP - Excel
www.longhead.com

[please keep replies in the newsgroup - email address unmonitored]

Ben,

Posting the code is good, but we need some help in the way of an explanation
of the problem, and other salient facts (which of course differ for each
problem). It is a little unreasonable to expect us to figure it out just
from code.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

"Ben_2004 " wrote in message
...
Bob? and what? Why do I only get my coded warning if I put duplicate
values into 2 cells, one at a time? But if I paste and copy, I don't
get any warning? In other words, if I paste and copy duplicate values
into a few cells at a time, the values stay in cells and my
"Check_Duplicates" function doesn't get triggered??


---
Message posted from http://www.ExcelForum.com/

Jake you are right. When choosing a few cells at the same time o
copying a value to a few cells at a time via "copy - paste", th
"Target" range is a multiple range and not the first cell.

I checked that with a msgbox "target= " &Target.address
and the address was a multiple range.

Your solution with intersect didn't help though. I will try just to d
a simple:

set My_Range = Target

for each My_Range in sheet1.Target etc...

Will post if it works.

Thank you so fa

--
Message posted from http://www.ExcelForum.com