VBA To Display Pop Up Alert When Duplicate Entry Is Made

attach the current file again

Hi
The file with three sheets and very little data is over 323kb so i have zipped it


Peter

Hi

The code I provided is not there in the workbook. I edited my original code. So you can copy that code and paste in the Workbook module. It is working fine here.

BTW, End Sub is missing in your workbook_open event code.

Hi
Thanks for that i must have deleted the en sub!

the pop up now works on every sheet, but i was after it searching all sheets so that if i was entering a reg in contract sheet but the reg had been archived
it would inform me that it was dulicated in that sheet so i could copy that data back into the live contract page


Peter

OK. Try this

Code:

---

Option Explicit

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

    Dim rFound  As Excel.Range
    Dim rCount  As Long
    Dim Shts    As Variant
    Dim i      As Long
   
    Shts = Array("USED CONTRACTS", "ARCHIVE", "CONTRACTS")
   
    Select Case UCase$(Sh.Name)
        Case "USED CONTRACTS", "ARCHIVE", "CONTRACTS"  '<<<<< add more sheets (in upper case)
            If Target.Column = 2 Then
                For i = LBound(Shts) To UBound(Shts)
                    rCount = rCount + Application.WorksheetFunction.CountIf(Worksheets(Shts(i)).UsedRange.Columns(2), Target.Value)
                    If rCount > 1 Then
                        Set rFound = Worksheets(Shts(i)).UsedRange.Columns(2).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
                                Exit For
                            End If
                        End If
                    End If
                Next
            End If
    End Select

End Sub

---

Again in thisworkbook module.

HI

Sorry to be a pain
It does not seem to work at all now?

I have nothing in (contracts,used contracts,archive)
row deletion code in (this workbook)
your new code in module 1

Is this correct?

Hi
If i put this in the workbook and not in module 1 it will work as before find duplications in the sheet i am in but not find a reg in archive
if i am in the contracts sheet

i have notice now that if there is a reg in the archive sheet and i type it in the contract sheet it finds its self on the contract sheet, so it is seeing the duplicated reg but not saying which sheet it is on and not taking you to that sheet.
Also when it locates a duplicate in the same sheet and you press ok to go to it .the sheet moves over one column so you cant see the customer name

Thanks for looking
Peter

It works fine here.

PFA.

Hi

I have tried your test file and it finds the regs on other sheets but it also finds itself on the sheet your on?

Cheers
Peter

Hi

Is this what you are after ?

Code:

---

Option Explicit

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

    Dim rFound  As Excel.Range
    Dim rCount  As Long
    Dim Shts    As Variant
    Dim i      As Long
   
    Shts = Array("CONTRACTS", "USED CONTRACTS", "ARCHIVE")
   
    Select Case UCase$(Sh.Name)
        Case "CONTRACTS", "USED CONTRACTS", "ARCHIVE"  '<<<<< add more sheets (in upper case)
            If Target.Column = 2 Then
                For i = LBound(Shts) To UBound(Shts)
                    rCount = rCount + Application.WorksheetFunction.CountIf(Worksheets(Shts(i)).UsedRange.Columns(2), Target.Value)
                    If rCount And rFound Is Nothing Then
                        Set rFound = Worksheets(Shts(i)).UsedRange.Columns(2).Find(What:=Target.Value, MatchCase:=False, Lookat:=xlWhole)
                    End If
                    If rCount > 1 Then
                        If MsgBox("The registration Number  " & Target.Value & _
                                "    has been found in row  " & rFound.Row & vbLf & "on Sheet '" & rFound.Parent.Name & "'" & 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
                            'rFound.Activate
                            Exit For
                        End If
                    End If
                Next
            End If
    End Select

End Sub

---