VBA To Display Pop Up Alert When Duplicate Entry Is Made

[peter renton]

Hi
I have attached a sample spread sheet with a vba code to detect duplicated reg numbers and take you to the original entry
unfortunatley it also shows the warning on unique enteries as well,could anybody help me with a solution to stop this happening


thanks Peter

[patel]

try this code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rFound As Excel.Range
    If Target.Column = 2 Then
      NewVal = Target.Value
      Application.EnableEvents = False
      Application.Undo 'the previous value is re-established.
      Set rFound = Range("B:B").Find(What:=NewVal, 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
                rFound.Activate
                Target.Value = NewVal
                Application.EnableEvents = True
         End If
      Else
        Target.Value = NewVal
        Application.EnableEvents = True
      End If
    End If
     
End Sub

[Admin]

Hi

Try this code.

Private Sub Worksheet_Change(ByVal Target As Range)
     
    Dim rFound As Excel.Range
    Dim rCount  As Long
    
    
    If Target.Column = 2 Then
        
        rCount = Application.WorksheetFunction.CountIf(Me.UsedRange.Columns(2), Target.Value)
        
        If rCount > 1 Then
            Set rFound = 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 Sub

[peter renton]

Hi

How can i amend the code so that it would also check in two other sheets one called used contracts and one called archive and take you there
if possible

[peter renton]

Thanks guys

thats spot on the first could did not pick up the reg in the warning bos but the second did

once any many thanks

Peter

[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.

[patel]

otherwise you have to copy the code on the other sheet

[peter renton]

Hi
I have tried to put the code in the workbook but an error comes up (method of data member not found) and highlights me.used range.
I have also tried to add the code in each sheet but still no joy, am i doing somthing wrong?


Peter

[Admin]

Hi

Replace Me with Sh

[peter renton]

hI
I have replaced that thanks the error has now gone, however it still will not locate a duplicated reg in either used or archive sheet?
i have placed it in a module on the workbook.
Would it also be able to say found reg ...... on row .... in sheet name?

Thanks Peter