VBA duplicate value (not using data validation)

Question

I have a question regarding catching a user for entering duplicate values in a sheet. We are unable to use data validation because cut/copy/paste throws out the data validation and allows them to enter the dupe value. I was originally using this code:

Option Explicit

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'******problem when copying entire row and pasting into new row, enables user to paste dupe Box ID #******

'Defining variables in Mailroom
Dim WS As Worksheet, EvalRange As Range
       
'Range to check for duplicates
Set EvalRange = Worksheets("Mailroom").Range("Box_ID_Number")
      
'Checking if entered value is in the defined range; also if cell is empty exit macro
If Intersect(Target, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub

'If user enters dupe value in specified range then error message pops up and event is undone
If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
    MsgBox Target.Value & " already appears as a Box ID Number. Please enter a unique ID."
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
End If

End Sub

The code works fine for keeping a user from typing a dupe value in the column for "Box ID Number." The problem I am having is that if the user is to copy a Box ID Number from a column and another cell from a different column, they are able to paste a Dupe Value that the _SheetChange does not catch. When we were first creating the code for this we were disabling cut/copy/paste functions; however, others using the sheet apparently still need that function for other portions of the sheet.

Any ideas?

Answer 1

Assuming that your users actually need to change only one cell at a time, I think the below thing should work (it's only the bottom part of your code):

If Intersect(Target, EvalRange) Is Nothing Then Exit Sub
If IsEmpty(Target) Then Exit Sub

'Check if only one cell in "Box_ID_Number" is changed
If Intersect(Target, EvalRange).Count > 1 Then
    MsgBox "One cell at a once please."
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
    Exit Sub
End If

If WorksheetFunction.CountIf(EvalRange, Intersect(Target, EvalRange)) > 1 Then
    MsgBox Target.Value & " already appears as a Box ID Number. Please enter a unique ID."
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
End If

I have removed Or Target.Cells.Count > 1 and instead of CountIf(EvalRange, Target.Value) in my version you see CountIf(EvalRange, Intersect(Target, EvalRange)). IF Intersect(Target, EvalRange)) is not one cell, you would again get Type Mismatch (13) error. Therefore, to prevent it, I've implemented the additional check you see.