VBA To Display Pop Up Alert When Duplicate Entry Is Made

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

try this code

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

---

Hi

Try this code.

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

---

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

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

Hi

Move the code into workbook module. Like

Code:

---

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.

otherwise you have to copy the code on the other sheet

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

Hi

Replace Me with Sh

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

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

---

Hi

its still not behaving correctley
if i have say reg number 3 on all three sheets already

when i type 3 again on the contact sheet it finds the newly added reg on that sheet no others.
when i type 3 again on the archive sheet it finds the one on the contract sheet but no others.
when i type 3 again on the used sheet it finds the on one the contracts sheet twice

sorry to keep pestering you on this, it looks like its almost there ;-)


REGARDS

Peter