Stop duplicate record

[burl_h]

I'm using the following code to stop duplicate records being entered
into column A. In principle the macro works great but I would like to
add some enhancements.

First, on entry I'd like a message to say which cell has a duplicate
record, if one exists.
Secondly, I'd like the cell pointer (active cell) to goto the
duplicate record if one exists.

Any help would be greatly appreciated.

Thanks
burl_h

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Integer
If Target.Column = 1 Then
If Not IsEmpty(Target.Value) Then
LastRow = Cells(65536, Target.Column).End(xlUp).Row
For i = 1 To LastRow
If i <> Target.Row Then
If Cells(i, Target.Column).Value = Target.Value Then
MsgBox Target.Value & " already exists.", vbExclamation
Target.Value = Empty
Exit For
End If
End If
Next i
End If
End If
End Sub

 

[Barb Reinhardt]

Try this (with some additional notes)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long 'Integer
'Check out the highest value for integer vs
'the last row number in Excel 2007.

Dim myCell As Excel.Range
Dim i As Long
If Target.Column = 1 Then
'If Not IsEmpty(Target.Value) Then
If Not IsEmpty(Target.Value) Then
'LastRow = Cells(65536, Target.Column).End(xlUp).Row
LastRow = Me.Cells(Me.Rows.Count, Target.Column).End(xlUp).Row
For i = 1 To LastRow
If i <> Target.Row Then
Set myCell = Me.Cells(i, Target.Column)
'If myCell.Value = Target.Value Then 'Value is what's displayed
If myCell.Value2 = Target.Value2 Then
MsgBox Target.Value & " already exists in cell " & myCell.Address,
vbExclamation
'Target.Value = Empty
Application.EnableEvents = False
Target.ClearContents
myCell.Select
Application.EnableEvents = True

Exit For
End If
End If
Next i
End If
End If
End Sub

 

[ozgrid.com]

Try;

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rDupe As Range
If Target(1, 1).Column = 1 Then
If Not IsEmpty(Target(1, 1)) Then
On Error Resume Next
Set rDupe = Range("A:A"). _
Find(What:=Target(1, 1), _
LookAt:=xlWhole, MatchCase:=False)
If rDupe Is Nothing Then
On Error GoTo 0
Exit Sub
Else
MsgBox "'" & Target(1, 1) & "' already exists"
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
.Goto rDupe
On Error GoTo 0
End With
End If
End If
End If
End Sub

 

[burl_h]

Barb/Ozgrid,

I tried both solutions, I found that Barb's worked fine. However the
ozgrid solution failed to work, it gave the message a duplicate
existed when one clearly didn't.

Regards
burl_h