VBA To Display Pop Up Alert When Duplicate Entry Is Made

[Admin]

Hi

Move the code into workbook module. Like

Option Explicit

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

    Dim rFound As Excel.Range
    Dim rCount  As Long
    
    Select Case UCase$(Sh.Name)
        Case "USED CONTRACTS", "ARCHIVE"    '<<<<< add more sheets
            If Target.Column = 2 Then
                
                rCount = Application.WorksheetFunction.CountIf(Sh.UsedRange.Columns(2), Target.Value)
                
                If rCount > 1 Then
                    Set rFound = Sh.Range("B:B").Find(What:=Target.Value, MatchCase:=False, Lookat:=xlWhole)
                     
                    If Not rFound Is Nothing Then
                        
                        If MsgBox("The registration Number  " & Target.Value & _
                        "    has been found in row  " & rFound.Row & vbCrLf & vbCrLf & _
                        "Do you want to view this entry?", vbQuestion + vbYesNo, "Confirm") = vbYes Then
                             
                             '// You might want to delete the 'new' entry/entire line here
                             '// otherwise the suplicate remains.
                             '// Application.EnableEvents = False
                             '// Target.Value = vbNullString
                             '// Application.EnableEvents = True
                             
                             '// Application.Goto rFound, True
                            rFound.Activate
                        End If
                    End If
                End If
            End If
     End Select

End Sub

Edit: Code edited.