Add to code looking for duplicates to not allow duplicates

[bdouglas1011]

i have code that looks at a range for duplicate entries but I want to add a change that if a duplicate is found it will not allow the duplicate to be chosen you must select another choice.

My code so far is:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim S As Variant
If Target.Column = 2 Then

Set S = Range("B3:B60").Find(Target.Value)
If Not S Is Nothing And S.Address <> Target.Address Then
MsgBox ("please choose another you can not have duplicate entries")
End If

End If
End Sub

what would I need to add for this to happen?

[Leith Ross]

Hello bdouglas1011,

This might work for you. This assumes B2 is the input cell.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim S As Range
    
    If Target.Address = "$B$2" Then
        Set S = Range("B3:B60").Find(Target.Value)
        If Not S Is Nothing And S.Address <> Target.Address Then
            Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
            Application.EnableEvents = True
            MsgBox ("Please choose another you can not have duplicate entries")
        End If
    End If
    
End Sub

[bdouglas1011]

I inserted your code but it seems to do nothing I can still choose a duplicate drop down selection. Would you like to see me sheet.

[Leith Ross]

Hello bdouglas1011,

Since my macro was based solely on the macro you posted, it would be best if you post your workbook.

[bdouglas1011]

Here is the workbook if you need the protection password its "Financial1"

the code should run on the Daily Chgs tab...it for the column b Drop downs. that if a user chooses a drop down that is already chosen the macro would not allow it.

[Leith Ross]

Hello Hello bdouglas1011,,

Thanks for posting the workbook. This layout is much different that what you described in your first post. Without the workbook, I would never have guessed this layout.

EDIT: the supplied password does not work for the Daily Chgs sheet.

[bdouglas1011]

the password is

Financial1

[Leith Ross]

Hello bdouglas1011

This was tricky but I got it to work. The macro below has been added to the attached workbook.

Sheet "Daily Chgs" - Worksheet_Change() Event Code

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim Match   As Range
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim x       As String
    
        If Not Intersect(Target, Range("B:B")) Is Nothing Then
            
            With Application.FindFormat
                .Clear
                .Interior.Color = RGB(240, 213, 212)
            End With
            
            Set Rng = Range("B9:B67").Resize(ColumnSize:=5)
            
            Set RngBeg = Rng.Find("", Target, xlValues, xlWhole, xlByRows, xlPrevious, False, False, True)
            
            If Not RngBeg Is Nothing Then
                Set RngEnd = Rng.Find("", Target, xlValues, xlWhole, xlByRows, xlNext, False, False, True)
                Set Rng = Range(RngBeg.Offset(1, 0), RngEnd.Offset(-1, 0)).Resize(ColumnSize:=5)
                
                Set Match = Rng.Find(Target.Value, , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
                
                If Not Match Is Nothing Then
                    x = Match.Address
                    
                    Set Match = Rng.FindNext(Match)
                    
                    If Not Match Is Nothing Then
                        If Match.Address = x Then Exit Sub
                        Application.EnableEvents = False
                            Target.Value = Empty
                            Target.Select
                            MsgBox "Please make another selection. Duplicates are not allowed."
                        Application.EnableEvents = True
                    End If
                    
                End If
                
            End If
                
        End If
        
        Application.FindFormat.Clear
    
End Sub

P.S. The password for "Daily Chgs" is Financial3. I found a reference in your code.

[bdouglas1011]

Good Morning I have an issue Now because I did not know cell fill color would come into play and I have been playing around with different color formatting to make it the most eye Pleasing.

Also, After inserting the row @ 67 in the worksheet it threw off my other code in the sheet in Module 3 so I get a Object Variable or with block variable not set now on the line.

lc = wd.Rows(8).Find("tot", MatchCase:=False).Column - 1

I am not sure how to correct this.

I have attached the formatted version I hope to use but it does not have fill color in the column b any more.

Can you advise

[Leith Ross]

Hello bdouglas1011,

Thanks for the update. and the current workbook.

I have a question about the drop downs. Your answer will affect how I revise the macro.

Will the drop downs show all the choices for all the sections or only the relevant choices for the section it appears in?

[bdouglas1011]

They get filtered by your choice in in D8

So If you select Directional in D8 Then only directional choices populate the relevant categories
& if you pick MWD (Or any other in D8) that filters the choices in each category.


I hope this helps

[Leith Ross]

Okay, it is partial listing based on the selection in D8.

Since separating the the areas by color is out, the only other way is I can separate the areas is by font.

Hopefully your not planning to change the font in the cells with drop downs.

[bdouglas1011]

No the Font can stay the Same

[Leith Ross]

Hello bdouglas1011,

I revamped the macro. I threw out the decision to use the font. Instead The macro looks for "TOTALS" in column "A" to define the end of the input table.

It now scans from B10 to the row above "TOTALS" for duplicate entries. Hopefully this will be bulletproof.

The Attached workbook has the new macro added.

Sheet "Daily Chgs" - Worksheet_Change() Event Code

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim Match   As Range
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim x       As String
    
        If Not Intersect(Target, Range("B:B")) Is Nothing Then
            
            Set RngBeg = Range("B10")
            
            Set RngEnd = Range("A:K").Find("TOTALS", , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
            Set Rng = Range(RngBeg, Cells(RngEnd.Row - 1, RngBeg.Column)).Resize(ColumnSize:=5)
                
                Set Match = Rng.Find(Target.Value, , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
                
                If Not Match Is Nothing Then
                    x = Rng.Address
                    
                    Set Match = Rng.FindNext(Match)
                    
                    If Not Match Is Nothing Then
                        If Match.Address = x Then Exit Sub
                        Application.EnableEvents = False
                            Target.Value = Empty
                            Target.Select
                            MsgBox "Please make another selection. Duplicates are not allowed."
                        Application.EnableEvents = True
                    End If
                    
                End If
                
            End If
        
        Application.FindFormat.Clear
    
End Sub

[bdouglas1011]

I just did a trial run and the duplicate part is working but I don't know why it throws off the VBA in Module 3.

It gives me 'Object variable or With block variable not set'


I don't get that error when I don't have the duplicate code in the sheet.

Do you have any ideas whys?

[Leith Ross]

Hello bdouglas1011,

It is not clear to me what the function of the macro in Module3 "NewDateRange" is.

I have re-written part of it. The part that copies the data from"Daily Chgs" to the "Job Ticket" worksheet. That works with no problems.

The part I can not understand is the code after that. The part of code using the Dictionary. Can explain what that part is supposed to do?

[bdouglas1011]

Thanks for your help i will have to look tomorrow I have to catch a flight

[bdouglas1011]

I have some time to look at everything and I got some help on the problem from earlier and discovered the scripting dictionary was not working with the duplicates so some changes were made and I thought everything was working great but then....

I chose some other choices checking on the duplicates and now I noticed that it wont allow me to choose anything ...everything is a duplicate whether it had been used or not.

I attached the Ver 7.0 to help know what version is what.

[bdouglas1011]

Any Ideas why it is stuck on Showing duplicates every time.

I went back to the code with the color format and it is working just fine the only thing I would like to add to it is if a user would manually delete an entry it would show an error. How can I correct it from doing that?
Runtime error 13 type mismatch

[Leith Ross]

Hello bdouglas1011,

Try this version and let me the results.