function to populate drop-list with unique and sorted values

[sylvio]

Dear friends,

Below is the function NoDups populating drop-down list in a user form with unique and sorted values.
Can it modified to populate regular drop-down set through Data validation?

Function NoDups(rng As Range)
  Dim arr(), i&, s$, x
  ' read data
  arr = Intersect(rng.Parent.UsedRange, rng).Value
  ' create list
  On Error Resume Next
  With New Collection
    For Each x In arr()
      s = Trim(x)
      If Len(s) > 0 Then
        If IsEmpty(.Item(s)) Then
          ' add sorted values to collection
          For i = 1 To .Count
            If s < .Item(i) Then Exit For
          Next
          If i > .Count Then .Add s, s Else .Add s, s, Before:=i
        End If
      End If
    Next
    ' copy to array
    ReDim arr(1 To .Count)
    For i = 1 To .Count
      arr(i) = .Item(i)
    Next
  End With


  NoDups = arr()
End Function

 

[ZVI]

Hi Sylvio,

There are some critical limitations of a data validation list source:
1. User Defined function like NoDups() can't be used in a formula of Data-Data validation-List-Source.
2. Regular drop down list should be referred directly or by a formula to the source range / named range.
3. In case items of the list are written explicitly to the validation source field the limitation of its length is 255 symbols only,

Thus, NoDups is not good for that purpose.
Possible solution can be in the below macro which creates in the hidden sheet the named range with sorted unique source items. That named range then can be used in Data-Data validation-List-Source.

Sub CreateSortedUniqueNamedRange(Source As Range, ListName As String, Optional RowOffset As Long)
'ZVI:2017-01-11 http://www.mrexcel.com/forum/excel-questions/982999-function-populate-drop-list-unique-sorted-values.html
' Source    is the source range
' ListName  is the name of the created named range
' RowOffset is the optional row offset in the source range. Use RowOffset:=1 in case the source range has a header.
 
  Const HiddenSheetName = "HiddenSheet"
  Dim a As Variant, i As Long, s As String, v As Variant
  Dim SrcRng As Range, ListRange
  Dim SrcSh As Worksheet, HiddenSh As Worksheet, Wb As Workbook
 
  ' Find source sheet and workbook
  Set SrcSh = Source.Worksheet
  Set Wb = SrcSh.Parent
 
  ' Check data in the source range
  Set SrcRng = Intersect(Source, SrcSh.UsedRange).Offset(RowOffset)
  If SrcRng Is Nothing Then
    MsgBox "No data found in the source range: '" & SrcSh.Name & "'!" & Source.Address(0, 0)
    Exit Sub
  End If
 
  ' Check/create hidden sheet
  Application.ScreenUpdating = False
  On Error Resume Next
  Set HiddenSh = Wb.Sheets(HiddenSheetName)
  If Err Then
    Set HiddenSh = Wb.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count))
    HiddenSh.Name = HiddenSheetName
    Err.Clear
  End If
  HiddenSh.Visible = xlSheetHidden
  Application.ScreenUpdating = True
 
  ' Check Listname in the source sheet
  Set ListRange = SrcSh.Names(ListName).RefersToRange
  If Err Then
    With HiddenSh.UsedRange
      Set ListRange = .Cells(1).Offset(, .Columns.Count)
    End With
    Err.Clear
  Else
    ListRange.ClearContents
    Set ListRange = ListRange.Cells(1)
  End If
 
  ' Populate values
  a = SrcRng.Value
  If Not IsArray(a) Then
    ReDim a(1 To 1, 1 To 1)
    a(1, 1) = SrcRng.Value
  End If
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each v In a
      s = Trim(v)
      If Len(s) Then
        If Not .Exists(s) Then
          i = i + 1
          a(i, 1) = s
          .Item(s) = vbNullString
        End If
      End If
    Next
    If i > 0 Then
      With ListRange.Resize(i)
        .Value = a
        .Sort .Cells(1)
        Wb.Names.Add ListName, .Cells
      End With
    End If
  End With
 
End_Sub
 
Sub Test1()
 
  Const ListName = "MyList01"
 
  ' Create named range MyList01
  CreateSortedUniqueNamedRange Sheets("Sheet1").Range("A2:A1000"), ListName 
  ' Create validation list in the selected cells
  With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & ListName
  End With
 
End Sub
 
Sub Test2()
 
  Const ListName = "MyList02"
 
  ' Create named range MyList02. The source range has a header.
   CreateSortedUniqueNamedRange Sheets("Sheet1").Columns(2), ListName, RowOffset:=1
 
  ' Create validation list in the selected cells
  With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & ListName
  End With
 
End Sub

 

[ZVI]

For more correct sorting replace in the above code this code line:
.Sort .Cells(1)
by that one:
.Sort .Cells(1), xlAscending, Header:=xlNo

 

[sylvio]

ZVI,
thank you very much for exhausting answer and help.

 

[sylvio]

sorry, exhaustive

 

[ZVI]

I'm glad it did the job for you. Thank you for the feedback!

 

[sylvio]

Dear Vladimir,
can the macro be simplified a bit?
I need to read data from a definite range, let's say, Sheet1, B2:B2000, and write the produced list of values to Sheet2, range A2:A2000.

 

[ZVI]

Hi Sylvio,
Try this:

Sub UniqueSortedNamedRange()
 
  '--> Settings
  Const ListName = "MyList01"       ' Use this name in the validation list formula
  Const Source = "Sheet1!B2:B2000"
  Const Destination = "Sheet2!A2"
  '<--
 
  ' Create sorted unique values
  With Range(Destination)
    .Resize(Range(Source).Count).Value = Range(Source).Value
    .RemoveDuplicates 1
    .Sort .Cells(1), xlAscending, Header:=xlNo
  End With
 
  ' Set the named range
  With Range(Destination)
    ActiveWorkbook.Names.Add ListName, .Resize(.Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row + 1)
  End With
 
End Sub

Regards

 

[ZVI]

Just for the case, to copy & sort use this version of the code:

Sub JustCopyAndSort()
 
  '--> Settings
  Const Source = "Sheet1!B2:B2000"
  Const Destination = "Sheet2!A2"
  '<--
 
  ' Copy & sort
  With Range(Destination).Resize(Range(Source).Count)
    .Value = Range(Source).Value
    .Sort .Cells(1), xlAscending, Header:=xlNo  ' <-- comment this line if sorting is  not required
  End With
 
End Sub

It does not remove duplicates nor creates named range.

 

[ZVI]

Hi Sylvio,
Try this:

Sub UniqueSortedNamedRange()
  ...
End Sub

Here is a bit improved version:

Sub UniqueSortedNamedRange()
 
  '--> Settings
  Const ListName = "MyList01"       ' Use this name in the validation list formula
  Const Source = "Sheet1!B2:B2000"
  Const Destination = "Sheet2!A2"
  '<--
 
  ' Create sorted unique values
  With Range(Destination).Resize(Range(Source).Count)
    .Value = Range(Source).Value
    .RemoveDuplicates 1
    .Sort .Cells(1), xlAscending, Header:=xlNo
  End With
 
  ' Set the named range
  With Range(Destination)
     ActiveWorkbook.Names.Add ListName, .Resize(.Cells(1).Offset(Range(Source).Count).End(xlUp).Row - .Row + 1)
  End With
 
End Sub