Avoid duplicate value in dropdownlist

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi Guys,
I encounter the error when applying the code to avoid any duplicate value in a column with a dropdownlist created from VBA. Appreciate any help to rectify the error.

VBA Code:
lr = Sheets("Data").Range("U2").End(xlDown).Row
    
strSortedAgt = "='Data'!$U$2:$U$" & lr
 
   With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:=strSortedAgt     
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   End With


'Prevent Duplicate Name Input

If Target.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
On Error GoTo ErrHandler:

If Not Intersect(Target, Range("A3:A" & lastRow)) Is Nothing Then
        If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
                    Application.DisplayAlerts = False
                    Target.ClearContents
                    Application.DisplayAlerts = True
                    MsgBox "AgentName already exists!"
        End If
End If

ErrHandler:
Application.EnableEvents = True
 

Attachments

  • error to add new name.png
    error to add new name.png
    50.5 KB · Views: 7

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Question:
1. Where do you put the code? in Sub Worksheet_Change ? Can you show us the entire code in that Sub?
2. Why do you create data validation in Sub Worksheet_Change?
 
Upvote 0
Hi Akuini, here is the codes. Also, the Add New Names to DropDown List code seems not work.


VBA Code:
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
      
   If Sh.Name = "Data" Then Exit Sub
        
   If Target.CountLarge > 1 Then Exit Sub
  
   Application.DisplayAlerts = False
   Application.EnableEvents = False
   Application.ScreenUpdating = False

    
If Not Intersect(Target, Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row + 1)) Is Nothing Then  'Workable but no continously
 
  If Target.Offset(-1) <> "" Then
 
     Cancel = True
      
     Dim lrA As Long
     Dim colAarray As Object
     Dim clA As Range
     Dim SortedColA_array As Variant
  
   'Creating a array list
    Set colAarray = CreateObject("System.Collections.ArrayList")
    
    'Physical Source in Column L
    'lr = Sheets("Data").Cells(Rows.Count, "L").End(xlUp).Row
    lrA = Range("A2").End(xlDown).Row
    For Each clA In Range("A3:A" & lrA)
          If Not colAarray.contains(clA.Value) Then colAarray.Add clA.Value
    Next clA
      
    colAarray.Sort
    SortedColA_array = colAarray.toarray
    
    'Output SortedColA_array to Sheet("Data") Column O
          
    Sheets("Data").Range("T2:T" & Sheets("Data").Range("T2").End(xlDown).Row).ClearContents
    Sheets("Data").Range("T2").Resize(UBound(SortedColA_array) + 1, 1).Value = Application.Transpose(SortedColA_array)

    End If

   'Compare Sheet("Data") Column N and Column O to find the Unused Names
    Const F = "TRANSPOSE(IF(ISNA(MATCH(S2:S#,T2:T¤,0)),S2:S#))"
 
        Dim V
        With Sheets("Data")
            V = .Cells(.Rows.Count, 21).End(xlUp).Row:  If V > 1 Then .Range("U2:U" & V).Clear
            V = Filter(.Evaluate(Replace(Replace(F, "#", .[S1].End(xlDown).Row), "¤", .[S1].End(xlDown).Row)), False, False)
            If UBound(V) > -1 Then .[U2].Resize(UBound(V) + 1).Value2 = Application.Transpose(V)
        End With
 
            Dim strSortedAgt As String
            Dim lr As Long
            
            
    'Create DropDown List to Column A
        
      lr = Sheets("Data").Range("U2").End(xlDown).Row
     'lr = Sheets("Data").Cells(Rows.Count, 21).End(xlUp).Row
    
     strSortedAgt = "='Data'!$U$2:$U$" & lr
 
   With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:=strSortedAgt     
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
   End With
  
   End If
      
    
   Application.DisplayAlerts = True
   Application.EnableEvents = True
   Application.ScreenUpdating = True
 
  
End Sub




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

Select Case Sh.Name
    Case "Data"
      Exit Sub
    Case Else
End Select
 
Application.ScreenUpdating = False 'Disabling the screen updating.

'ProperCase in Column A

Dim lastRow As Long
lastRow = Range("A3").End(xlDown).Row
'lastRow = Cells(Rows.Count, 1).End(xlUp).Row


If Target.CountLarge > 1 Then Exit Sub
On Error GoTo ErrHandler:

If Not Intersect(Target, Range("A3:A" & lastRow)) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
            Application.EnableEvents = False
            Target.Value = StrConv(Target.Text, vbProperCase)
            Application.EnableEvents = True
         End If
        
End If


'Prevent Duplicate Name Input

If Target.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
On Error GoTo ErrHandler:

If Not Intersect(Target, Range("A3:A" & lastRow)) Is Nothing Then
        If WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
                    Application.DisplayAlerts = False
                    Target.ClearContents
                    Application.DisplayAlerts = True
                    MsgBox "AgentName already exists!"
        End If
End If


'Add New Name to DropDown List

Dim srchRng As Range, oRng As Range
Dim M As Long
Dim slastRow As Long, olastRow As Long
olastRow = Range("A3").End(xlDown).Row
slastRow = Worksheets("Data").Range("L2").End(xlDown).Row
Set oRng = Range("A3:A" & olastRow)
Set srchRng = Worksheets("Data").Range("L2:L" & slastRow)

If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("A3:A" & lastRow)) Is Nothing Then
        If Not IsNumeric(Target.Value) Then
Application.EnableEvents = False
On Error Resume Next
    If Not IsNumeric(Target.Value) Then
        M = srchRng.Find(Target.Value).Row
        If M = 0 Then Worksheets("Data").Range("L" & slastRow + 1).Value = Target.Value
    End If
Application.EnableEvents = True

End If
End If

End Sub


AgentProposal_Roster0728_1004.xlsm
ABCDEFGHIJKLM
1MDateAttendance24-Feb25-Feb26-Feb27-Feb28-Feb1-Mar2-Mar3-Mar4-Mar5-Mar6-Mar
2DateSummary(5)(4)(3)(2)(1)123456
3John GT:23 L:0 D:21 E:0 N:0GDDD
4Mary KT:23 L:0 D:2 E:0 N:0D3D3D3
5Jeffrey LaiT:23 L:0 D:0 E:0 N:0D1
6Zita VT:23 L:0 D:1 E:0 N:1KN
202203
Cells with Data Validation
CellAllowCriteria
H3:M6List=ShiftcodeNew
A3List=Data!$U$2:$U$14
A4List=Data!$U$2:$U$13
A5List=Data!$U$2:$U$12
A6List=Data!$U$2:$U$11



AgentProposal_Roster0728_1004.xlsm
LRSTU
1AgentAgentFrom ColumnAFind Missing bet N & O
2Cat GBady BJeffrey LaiBady B
3Mary KCat GJohn GCat G
4John GJack SMary KJack S
5Ken CJeffrey LaiZita VKen C
6Zita VJohn GLarry Q
7Larry QKen CMandy H
8Mandy HLarry QNacy L
9Warus OMandy HPeter B
10Jack SMary KWarus O
11Nacy LNacy L
12Peter BPeter B
13Bady BWarus O
14Jeffrey LaiZita V
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Data
Cells with Data Validation
CellAllowCriteria
L2:L30Custom=COUNTIF($L:$L,L2)=1
 
Upvote 0
Try this:
This code is to prevent inserting duplicate values in a defined range by using data validation.
Note:
1. In sheet "deList", create a named range "xName", Scope = Workbook, refers to any cell, e.g A1, then use it as the source of data validation
2. If the data validation sometimes doesn’t work it maybe because the Application.EnableEvents somehow get turned off. If that happens just run Sub toEnableEvent().

The code:

VBA Code:
Option Explicit
'=============== ADJUST THE CODE IN THIS PART: ===================================

'sheet's name where the list (for combobox) is located. [in the sample: sheet "deList"]
Private Const sList As String = "deList"

'cell where the list start
Private Const sCell As String = "D2"

'helper column
Private Const xH As String = "F"

'range where data validation is located
Private Const xD As String = "A3:A20"

'the named range
Private Const xN As String = "xName"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Cells.CountLarge > 1 Then Exit Sub

If Not Intersect(Target, Range(xD)) Is Nothing Then
    If isValid(Target) Then 'if activecell has data validation type 3
       If Target.Validation.Formula1 = "=" & xN Then
       Dim va, vb, x, d As Object
                With Sheets(sList)
                    vb = .Range(sCell, .Cells(.Rows.Count, .Range(sCell).Column).End(xlUp))  'the original list
                End With
                
                Set d = CreateObject("scripting.dictionary")
                d.CompareMode = vbTextCompare
    
                For Each x In vb
                    d(x) = Empty
                Next
            
            If WorksheetFunction.CountA(Range(xD)) > 0 Then
                
                va = Range(xD) ' range with data validation
                For Each x In va
                    If d.Exists(x) Then d.Remove x
                Next
            End If
            
            If d.Exists("") Then d.Remove ""
            
                Application.EnableEvents = False
                Application.ScreenUpdating = False
                With Sheets(sList).Columns(xH)
                    .ClearContents
                    
                    If d.Count = 0 Then .Cells(1).Name = xN: Exit Sub
                    
                    .Cells(1).Resize(d.Count, 1) = Application.Transpose(Array(d.Keys))
                    .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
                    .Cells(1).Resize(d.Count, 1).Name = xN
                End With
                Application.ScreenUpdating = True
                Application.EnableEvents = True
       End If
    End If
End If

End Sub

Function isValid(f As Range) As Boolean
    Dim v
    On Error Resume Next
        v = f.Validation.Type
    On Error GoTo 0
    isValid = v = 3
End Function

Sub toEnableEvent()
Application.EnableEvents = True
End Sub


Example:
 
Upvote 0
Sorry, I forgot something.
One caveat of using macro is when a macro changes/writes something in the sheet it will clear the Undo Stack, so at that point you can't use UNDO. With my code above it happens whenever you put the cursor in the cell with the data validation.
So I think it's better to use formula instead of vba. And perhaps this nice solution from @Peter_SSs will work for you.
 
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,344
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top