Automatically Check Each Worksheet For Duplicate Entry

  • Thread starter Thread starter Hasan
  • Start date Start date
H

Hasan

hi

got a situation wherby in column A, there is a list of values for the
user to select using data validation list,

need to prevent the user from selecting 2 similar data in any of the
cells in column A of entire workbook

a error message has to appear to warn the user if such a situation
arises and then point to that cell value in a workbook

any idea how to do it?

Not sure the code i am using below is right...

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

If Intersect(Target, Range("A2:A200")) Is Nothing Then Exit Sub

For Each wsLoop In ThisWorkbook.Worksheets
If Not wsLoop.Name = "Sheet1" Then
If WorksheetFunction.CountIf(wsLoop.Range("A2:A200"),
Target) > 0 Then
MsgBox "That entry already exists in the " +
wsLoop.Name + " sheet"
Application.EnableEvents = 0
Target.ClearContents
wsLoop.Select
Application.EnableEvents = 1
End If
End If
Next wsLoop

End Sub


- Thanks
 
Make sure you put the code in the ThisWorkbook module:

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsLoop As Worksheet

If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
Exit Sub
End If

If Target.Cells.Count > 1 Then
Exit Sub 'single cell at a time
End If

For Each wsLoop In ThisWorkbook.Worksheets
If wsLoop.Name = Sh.Name Then
'skip it
Else
If Application.CountIf(wsLoop.Range("A2:A200"), Target.Value) > 0 _
Then
MsgBox "That entry already exists in the " _
& wsLoop.Name & " sheet"
Application.EnableEvents = False
Target.ClearContents
wsLoop.Select
Exit For 'stop looking for more
Application.EnableEvents = True
End If
End If
Next wsLoop

End Sub
 
Make sure you put the code in the ThisWorkbook module:

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsLoop AsWorksheet

    If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
        Exit Sub
    End If

    If Target.Cells.Count > 1 Then
        Exit Sub 'single cell at a time
    End If

    ForEachwsLoop In ThisWorkbook.Worksheets
        If wsLoop.Name = Sh.Name Then
            'skip it
        Else
            If Application.CountIf(wsLoop.Range("A2:A200"), Target.Value) > 0 _
             Then
                 MsgBox "Thatentryalready exists in the" _
                           & wsLoop.Name & " sheet"
                Application.EnableEvents = False
                Target.ClearContents
                wsLoop.Select
                Exit For 'stop looking for more
                Application.EnableEvents = True
            End If
        End If
    Next wsLoop

End Sub
















--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Hi Dave... thanks for the help.

I want the macro to select the value after clicking OK on message box.
Currently the code is showing me the sheet where the value exsists
after clicking OK message box but not the cell value
 
I didn't notice that in your first post.

Since you want to go to that cell, then there's no reason to use
application.countif to see if the value is there. That doesn't give you enough
info to actually go there.

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsLoop As Worksheet
Dim FoundCell As Range

If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
Exit Sub
End If

If Target.Cells.Count > 1 Then
Exit Sub 'single cell at a time
End If

For Each wsLoop In ThisWorkbook.Worksheets
If wsLoop.Name = Sh.Name Then
'skip it
Else
With wsLoop.Range("A2:A200")
Set FoundCell = .Cells.Find(what:=Target.Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If FoundCell Is Nothing Then
'not found
Else
MsgBox "That entry already exists here:" & vbLf _
& FoundCell.Address(external:=True)
Application.EnableEvents = False
Target.ClearContents
Application.Goto FoundCell, scroll:=True 'or false??
Application.EnableEvents = True
Exit For
End If
End If
Next wsLoop

End Sub

Notice that the "exit for" as moved down a bit. It was a bug in the earlier
version. Enabling events would never take place, since the "exit for" line left
the loop.
 
I didn't notice that in your first post.

Since you want to go to that cell, then there's no reason to use
application.countif to see if the value is there.  That doesn't give you enough
info to actually go there.

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsLoop AsWorksheet
    Dim FoundCell As Range

    If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
        Exit Sub
    End If

    If Target.Cells.Count > 1 Then
        Exit Sub 'single cell at a time
    End If

    ForEachwsLoop In ThisWorkbook.Worksheets
        If wsLoop.Name = Sh.Name Then
            'skip it
        Else
            With wsLoop.Range("A2:A200")
                Set FoundCell = .Cells.Find(what:=Target.Value, _
                                            After:=.Cells(.Cells.Count), _
                                            LookIn:=xlValues, _
                                            LookAt:=xlWhole, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=False)
            End With

            If FoundCell Is Nothing Then
                'not found
            Else
                 MsgBox "Thatentryalready exists here:"& vbLf _
                    & FoundCell.Address(external:=True)
                Application.EnableEvents = False
                Target.ClearContents
                Application.Goto FoundCell, scroll:=True 'or false??
                Application.EnableEvents = True
                Exit For
            End If
        End If
    Next wsLoop

End Sub

Notice that the "exit for" as moved down a bit.  It was a bug in the earlier
version.  Enabling events would never take place, since the "exit for" line left
the loop.








--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Hi Dave,

I have tried pasting your code in "Thisworkbook" but its not working.
I am still able to reselect/reenter the same values from data
validation dropdown
 
Add this to the top of the code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
msgbox "workbook_sheetchange fired"
...


If you don't see the message box after you make a change, then make sure that
macros are enabled for this workbook. (You may have to close the workbook and
reopen it to see the enable macros prompt.)

And make sure that events are still enabled.

Open the VBE (alt-f11 is one way)
hit ctrl-g (to see the immediate window)
type this
application.enableevents = true
and hit enter

Then back to excel to test.
 
Add this to the top of the code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  msgbox "workbook_sheetchange fired"
  ...

If you don't see the message box after you make a change, then make sure that
macros are enabled for this workbook.  (You may have to close the workbook and
reopen it to see the enable macros prompt.)

And make sure that events are still enabled.

Open the VBE (alt-f11 is one way)
hit ctrl-g (to see the immediate window)
type this
application.enableevents = true
and hit enter

Then back to excel to test.








--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Its woking fine now.. thanks alot Dave.

Is there a way to excelude "Sheet3" from find criteria i.e. search for
the value in all worksheet in workbook excluding "Sheet3" ?
 
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsLoop As Worksheet
Dim FoundCell As Range

If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
Exit Sub
End If

If Target.Cells.Count > 1 Then
Exit Sub 'single cell at a time
End If

For Each wsLoop In ThisWorkbook.Worksheets
Select Case LCase(wsLoop.Name)
Case Is = LCase(Sh.Name), LCase("Sheet3")
'skip it
Case Else
With wsLoop.Range("A2:A200")
Set FoundCell = .Cells.Find(what:=Target.Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If FoundCell Is Nothing Then
'not found
Else
MsgBox "That entry already exists here:" & vbLf _
& FoundCell.Address(external:=True)
Application.EnableEvents = False
Target.ClearContents
Application.Goto FoundCell, scroll:=True 'or false??
Application.EnableEvents = True
Exit For
End If
End Select
Next wsLoop

End Sub
 
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsLoop AsWorksheet
    Dim FoundCell As Range

    If Intersect(Target, Sh.Range("A2:A200")) Is Nothing Then
        Exit Sub
    End If

    If Target.Cells.Count > 1 Then
        Exit Sub 'single cell at a time
    End If

    ForEachwsLoop In ThisWorkbook.Worksheets
        Select Case LCase(wsLoop.Name)
            Case Is = LCase(Sh.Name), LCase("Sheet3")
                'skip it
            Case Else
                With wsLoop.Range("A2:A200")
                    Set FoundCell = .Cells.Find(what:=Target.Value, _
                                                After:=.Cells(.Cells.Count), _
                                                LookIn:=xlValues, _
                                                LookAt:=xlWhole, _
                                                SearchOrder:=xlByRows, _
                                                SearchDirection:=xlNext, _
                                                MatchCase:=False)
                End With

                If FoundCell Is Nothing Then
                    'not found
                Else
                     MsgBox "Thatentryalready exists here:" & vbLf _
                        & FoundCell.Address(external:=True)
                    Application.EnableEvents = False
                    Target.ClearContents
                    Application.Goto FoundCell, scroll:=True 'or false??
                    Application.EnableEvents = True
                    Exit For
                End If
        End Select
    Next wsLoop

End Sub








--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

The macro is not searching for the duplicate entries in active
worksheet.
 
No, it doesn't. Same as the previous 3 suggestions.

This avoids Sheet3 and the current sheet:
Case Is = LCase(Sh.Name), LCase("Sheet3")
'skip it
Click to expand...

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsLoop As Worksheet
Dim FoundCell As Range
Dim myAddr As String
Dim TopRng As Range
Dim BotRng As Range
Dim BigRng As Range
Dim LastRow As Long
Dim FirstRow As Long

myAddr = "A2:A200"
With Sh.Range(myAddr)
FirstRow = .Row
LastRow = .Rows(.Rows.Count).Row
End With

If Intersect(Target, Sh.Range(myAddr)) Is Nothing Then
Exit Sub
End If

If Target.Cells.Count > 1 Then
Exit Sub 'single cell at a time
End If

For Each wsLoop In ThisWorkbook.Worksheets
Select Case LCase(wsLoop.Name)
Case Is = LCase("Sheet3")
'skip it
Case Else
Set BigRng = wsLoop.Range(myAddr)
If LCase(wsLoop.Name) = LCase(Sh.Name) Then
With BigRng
If Target.Row = FirstRow Then
'in row 2, don't include it
Set BigRng = .Resize(.Rows.Count - 1).Offset(1, 0)
Else
If Target.Row = LastRow Then
'in row 200, don't include it
Set BigRng = .Resize(.Rows.Count - 1)
Else
Set TopRng = wsLoop.Range("A" & FirstRow _
& ":A" & Target.Row - 1)
Set BotRng = wsLoop.Range("A" & Target.Row + 1 _
& ":A" & LastRow)
Set BigRng = Union(TopRng, BotRng)
End If
End If
End With
End If

With BigRng
Set FoundCell = .Cells.Find(what:=Target.Value, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With

If FoundCell Is Nothing Then
'not found
Else
MsgBox "That entry already exists here:" & vbLf _
& FoundCell.Address(external:=True)
Application.EnableEvents = False
Target.ClearContents
Application.Goto FoundCell, scroll:=True 'or false??
Application.EnableEvents = True
Exit For
End If
End Select
Next wsLoop

End Sub
 
Thanks alot Dave... its working perfect, as i wanted. Thanks again- Hide quoted text -

- Show quoted text -
Click to expand...

I'm trying to compare two columns for new entries selected via data
validation list. Sheet3 Column A is the source information and sheet3
column B is the column to compare against. If there are new entries
selected in any sheet of workbook in column A I'd like the macro to
compare the value with the Sheet3 Column A and sheet3 column B. For
example

Sheet3 has following data

Column A ColumnB
123456 Apple
456789 Orange
147894 Pineapple
159357 Orange

My workbook has 4 sheets(Apple, Orange, Pineapple & Sheet 3)

Being in Apple worksheet if the user select 456789 value then the
macro should compare it with sheet3 columnB value, if its orange then
a message box should pop up saying "this Number should go in Orange
worksheet" and same way
 
I don't understand the new question.
I'm trying to compare two columns for new entries selected via data
validation list. Sheet3 Column A is the source information and sheet3
column B is the column to compare against. If there are new entries
selected in any sheet of workbook in column A I'd like the macro to
compare the value with the Sheet3 Column A and sheet3 column B. For
example

Sheet3 has following data

Column A ColumnB
123456 Apple
456789 Orange
147894 Pineapple
159357 Orange

My workbook has 4 sheets(Apple, Orange, Pineapple & Sheet 3)

Being in Apple worksheet if the user select 456789 value then the
macro should compare it with sheet3 columnB value, if its orange then
a message box should pop up saying "this Number should go in Orange
worksheet" and same way
Click to expand...
 
I don't understand the new question.











--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Coloum A data validation list in all worksheets is from sheets3 column
A. And Sheet3 has following data


Column A ColumnB
123456 Apple
456789 Orange
147894 Pineapple
159357 Orange

If the user is in apple worksheet and select value "456789"(which is a
new value in the workbook) from drop down a message box should pop up
saying "this Number should go in Orange worksheet"
 
I'm not sure if this gets incorporated into the earlier code or if it's for a
single sheet, but maybe this will get you started:

You could use something like:

Dim res as variant

res _
= application.vlookup(target.value,worksheets("Sheet3").range("A:B"),2,false)

if iserror(res) then
msgbox "Not found on sheet3"
else
msgbox "This Number should go in " & res & " worksheet."
end if
 
I'm not sure if this gets incorporated into the earlier code or if it's for a
single sheet, but maybe this will get you started:

You could use something like:

Dim res as variant

res _
 = application.vlookup(target.value,worksheets("Sheet3").range("A:B"),2,false)

if iserror(res) then
   msgbox "Not found on sheet3"
else
   msgbox "This Number should go in " & res & "worksheet."
end if
Click to expand...

I have pasted this in the earlier code.

- Even though the value selected is for the correct worksheet, i am
getting the message which i should not

- Its not clearing the data after clicking "OK" on message box"

- As the Coloum A data validation list in all worksheets is from
sheets3 column A. Below code is not required

if iserror(res) then
msgbox "Not found on sheet3"
 
Add target.clearcontents to clear the cell that had the value entered.











--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

How do i aviod the message if the value selected is for the correct
sheet ?
 
if lcase(sh.name) = lcase(res) then
'no message required
else
'show the message
end if
 
if lcase(sh.name) = lcase(res) then
  'no message required
else
  'show the message
end if







--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

I have edited the code as shown below and pasted in "ThisWorkbook" but
still the same. Its poping up the message for the selected values.


Dim res as variant
res _
= application.vlookup(target.value,worksheets("Sheet3").range("A:B"),
2,false)

if lcase(sh.name) = lcase(res) then
'no message required
else
msgbox "This Number should go in " & res & " worksheet."
Target.Clearcontents
end if
 
Maybe there's a difference in the name of the sheet you're changing and what you
typed into the table in Sheet3.

I'd add:

msgbox "***" & sh.name & "***" & vblf & "***" & res & "***"

to see if I could see a difference.
 
Back
Top