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]

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

[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

[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

[patel]

attach the current file again

[peter renton]

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


Peter

[Admin]

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.

[peter renton]

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

[Admin]

OK. Try this


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(S hts(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.

[peter renton]

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?

[peter renton]

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

[Admin]

It works fine here.

PFA.

[peter renton]

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

[Admin]

Hi

Is this what you are after ?


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(S hts(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

[peter renton]

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