Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Erik Van Geit
'080624 2313
'no duplicates allowed on this sheet or other sheets
'within the range "RngAddress"
'multiple changes within range not allowed, unless clearing data
Dim sht As Worksheet
Dim dup As Range
Dim RngAddress As String
Dim msg As String
RngAddress = "D1:D" & Rows.Count 'range to check
If Intersect(Target, Range(RngAddress)) Is Nothing Then Exit Sub
If Application.CountA(Target) = 0 Then Exit Sub
If Target.Count > 1 Then
msg = "Please change only one item at a time in the range " & RngAddress
Else
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> Sh.Name Then
Set dup = sht.Range(RngAddress).Find(What:=Target, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not dup Is Nothing Then
msg = "The item """ & Target & """ can be found on sheet """ & sht.Name & """ in cell " & dup.Address(0, 0)
Exit For
End If
Else
If Application.CountIf(sht.Range(RngAddress), Target) > 1 Then
msg = "The item """ & Target & """ is already in the list on this sheet."
Exit For
End If
End If
Next sht
End If
If Len(msg) > 0 Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
MsgBox msg, vbCritical, "ERROR"
End If
End Sub