Preventing Duplicates In Data Entry vba in all cells

[Luthius]

Hey Guys, I need a function that do a loop through all cells in worksheet based in criteria, not allowing data entry of duplicates values. The criteria I'll put in function for example:

Public Function NoToDuplicate(column as interger)
'The loop
...
Msgbox ("This is a duplicate value")
...
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Call NoToDuplicate(1)
End Sub

For Example:
Everytime when I'll put some value in column (myCriteria - for example "A" column), the function will check if there's the same value in all cells of the column (myCriteria - for example "A" column) of all sheets of my workbook.
All 'A Columns' of all sheets from the same workbook will be checked and if there's duplicate value a msgbox ("This is a duplicate value")

Luthius

 

[Nalani]

Don't know what you have tried on your own or how many sheets in the Workbook.

I'm not trying to do all Your Searches or Tests. Just don't want to duplicate anything that You have tried.

I did do a few Searches and found the below that might help you along:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Target.Column = 1 Then Exit Sub    'Only work on column A
    If Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A:A"), Sheets("Sheet1").Range("A" & Target.Row).Value) _
    + Application.WorksheetFunction.CountIf(Sheets("Sheet2").Range("A:A"), Sheets("Sheet2").Range("A" & Target.Row).Value) > 1 Then
        MsgBox "You have entered a duplicate, please try again"
    End If
End Sub

Found here:
http://www.mrexcel.com/forum/showthread.php?t=81975

Try it and see if it's what you need.

 

[mikerickson]

1) Why do you need VB code? Native Excel performs better than VB, if it can be done with native Excel.

What is the sheet name of the column A that you spoke of?
Where on the other sheets are the ID's that are not to be duplicated?

Where is the user making their entry, in the special column A or in one of the areas on the other sheets?

 

[Nalani]

I think the OP is looking for something that If:

1. A value is placed in any cell within Column A of Any sheet.
2. Code or Formula, will check all sheets if that value has been entered in Column A of any of the Other Sheets.
3. If so, then do something with it, (which at this point is not declared)

Luthius, if that is the case, please confirm or clarify.

I think what I provided is going down that road, and currently produceing a MsgBox, just not sure what is needed.

 

[mikerickson]

If those are the requirements, then putting this in the ThisWorkbook code module should work.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim oneSheet As Worksheet
    Dim oneCell As Range, keyColumn As Range
    Dim cummulativeCount As Long

    Set keyColumn = Sh.Range("A:A").EntireColumn: Rem adjust
    
    If Not (Application.Intersect(Target, keyColumn) Is Nothing) Then
        For Each oneCell In Application.Intersect(Target, keyColumn)
            cummulativeCount = 0
        
            For Each oneSheet In ThisWorkbook.Sheets
                cummulativeCount = cummulativeCount + Application.CountIf(oneSheet.Range(keyColumn.Address), oneCell.Value)
            Next oneSheet
            
            If 1 < cummulativeCount Then
                MsgBox "Duplicate entered in " & oneCell.Address(, , , True)
            End If
        Next oneCell
    End If
End Sub

 

[Luthius]

I was thinking something like this. But is not working

'....
counter = 0
For i = 1 To Sheets.Count
If Application.WorksheetFunction.CountIf(Sheets(i).Range("A:A"), Sheets(i).Range("A" & Target.Row).Value) > 1 Then
counter = counter + 1
End If
Next i
'....

HELP guys please....

 

[Luthius]

Nalani
Its exactly as you wrote.

I think the OP is looking for something that If:

1. A value is placed in any cell within Column A of Any sheet.
2. Code, will check all sheets if that value has been entered in Column A of any of the Other Sheets.
3. If so, then do something with it, (which at this point is not declared)
.

PS
mikerickson

Your code unfortunately is not working.
I tested it, and nothing.
Thanks for your help

 

[Luthius]

Sorry Mikerickson

I tested in wrong place.
It works..................

Great, thans a lot for all that tried to help me.
And mikerickson, thanks and thanks again. It's exactly what I need.

Hugs

 

[Nalani]

Not to hi-jack this thread, but:

Mike's code works as expected with the Msg Box giving the ActiveSheet's cell address after finding a duplicate.

I have tried to modify the code to give the Address of Which sheet the duplicate resides on to no avail.

Is this possible?

Example: On sheet2 I have the test values of "you", "me" , "them" , "us".

On Sheet1, I enter "me" in a cell (A4) for example. Currently the MsgBox will tell me that I have entered a duplicate in Sheet1!$A$4.

What would be needed to tell me that "me" is located in Sheet2 of whatever cell it is in?

I have tried the Find Method and a few other test, but ended up butchering up the code so bad I don't even want to post what I tried. (too ashamed)

Any Ideas or Guidance?

 

[gverde]

If those are the requirements, then putting this in the ThisWorkbook code module should work.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim oneSheet As Worksheet
    Dim oneCell As Range, keyColumn As Range
    Dim cummulativeCount As Long
 
    Set keyColumn = Sh.Range("A:A").EntireColumn: Rem adjust
 
    If Not (Application.Intersect(Target, keyColumn) Is Nothing) Then
        For Each oneCell In Application.Intersect(Target, keyColumn)
            cummulativeCount = 0
 
            For Each oneSheet In ThisWorkbook.Sheets
                cummulativeCount = cummulativeCount + Application.CountIf(oneSheet.Range(keyColumn.Address), oneCell.Value)
            Next oneSheet
 
            If 1 < cummulativeCount Then
                MsgBox "Duplicate entered in " & oneCell.Address(, , , True)
            End If
        Next oneCell
    End If
End Sub

hello all,
if i wanted to modify the cells that are duplicates with a different font color, how could this be added. i tried something like adding a with after the msg box but no cigar...

 

[mikerickson]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim oneSheet As Worksheet
    Dim oneCell As Range, keyColumn As Range
    Dim cummulativeCount As Long
 
    Set keyColumn = Sh.Range("A:A").EntireColumn: Rem adjust
 
    If Not (Application.Intersect(Target, keyColumn) Is Nothing) Then
        For Each oneCell In Application.Intersect(Target, keyColumn)
            cummulativeCount = 0
 
            For Each oneSheet In ThisWorkbook.Sheets
                cummulativeCount = cummulativeCount + Application.CountIf(oneSheet.Range(keyColumn.Address), oneCell.Value)
                If cummulativeCount Then
                    With oneSheet.Range(keyColumn)
                        MsgBox oneCell.Address(,,,True) & " duplicates " & _
                            .Find(what:=CStr(oneCell.Value), after:=.Cells(1,1)).Address(,,,True)
                    End With
                End If
            Next oneSheet
 
        Next oneCell
    End If
End Sub