VBA duplicate value (not using data validation) - excel

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.

Answer 2

#ZygD ! nailed it with Intersect(Target, EvalRange)
Finished code looks like this:
Option Explicit
Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Defining variables in Mailroom
Dim WS As Worksheet, EvalRange As Range
'Range to check for duplicates
Set EvalRange = Worksheets("Mailroom").Range("Box_ID_Number")
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 at a time
If Intersect(Target, EvalRange).Count > 1 Then
MsgBox "Unable to modify greater than 1 Box ID Number at a time. Please select one Box ID Row."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
End If`
'check for dupe value in Box ID Number Column; if copy and pasting entire row, dupe check still holds
If WorksheetFunction.CountIf(EvalRange, Intersect(Target, EvalRange)) > 1 Then
MsgBox Intersect(Target, EvalRange) & " already appears as a Box ID Number. Please enter a unique ID."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub