VBA User Form Combo Box Sort Unique Values

[powerpivotlegal]

Hello,

I'm trying to have a SearchUserForm populate a combo box with non-duplicate unique values that is sorted alphabetically when the form is launched.

The following code gives me the unique values in the combo box but the list is not sorted.

Private Sub UserForm_Initialize()


'Empty ProjectNameSearchComboBox
ProjectNameSearchComboBox.Text = ""


'Empty PartnerNameSearchTextBox
PartnerNameSearchTextBox.Text = ""


'Empty StatusSearchTextBox
StatusSearchTextBox.Text = ""


'Empty CommentsSearchTextBox
CommentsSearchTextBox.Text = ""

Dim oneValue As Variant
Set SourceSheet = Worksheets("Project List")
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row

With ThisWorkbook.Sheets("Project List").Range("A2:A" & LastRow)
For Each oneValue In .Value
If (Application.CountIf(.Cells, CStr(oneValue)) = 1) Then
Me.ProjectNameSearchComboBox.AddItem CStr(oneValue)
End If
Next oneValue
End With
End Sub

The other code I've found on another forum post (shown below) gives me the unique values sorted alphabetically but it displays the first alphabetical option in the combo box as a default rather than a blank combo box.

Private Sub UserForm_Initialize()


'Empty ProjectNameSearchComboBox
ProjectNameSearchComboBox.Text = ""


'Empty PartnerNameSearchTextBox
PartnerNameSearchTextBox.Text = ""


'Empty StatusSearchTextBox
StatusSearchTextBox.Text = ""


'Empty CommentsSearchTextBox
CommentsSearchTextBox.Text = ""


Application.ScreenUpdating = False
Dim Coll As Collection, cell As Range, LR As Long
Dim unsorted As Boolean, i As Integer, temp As Variant
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Project List")
LR = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
With ProjectNameSearchComboBox
.Clear
For Each cell In SourceSheet.Range("A2:A" & LR)
If Len(cell) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
unsorted = True
Do
unsorted = False
For i = 0 To UBound(.List) - 1
If .List(i) > .List(i + 1) Then
temp = .List(i)
.List(i) = .List(i + 1)
.List(i + 1) = temp
unsorted = True
Exit For
End If
Next i
Loop While unsorted = True
.ListIndex = 0 'optional
End With
Set Coll = Nothing
Set SourceSheet = Nothing
Application.ScreenUpdating = True

End Sub

How can I fix either code to give me an alphabetical sort of just the unique/non-duplicate values in Column A where the combo box does not display default options or the first option in the list?

Thanks.

 

[Leith Ross]

Hello powerpivotlegal,

This is a routine I use a lot. It will extract the unique values from a range and sort them in ascending order. The code also has the option to sort in descending order also.

The worksheet is set to "Sheet1" and the starting cell is "A2". The Combo Box name is "ComboBox1". You can change these if you need to. The lines to change are marked in blue.

Private Sub UserForm_Initialize()

    Dim Cell        As Range
    Dim col         As Variant
    Dim Descending  As Boolean
    Dim Entries     As Collection
    Dim Items       As Variant
    Dim index       As Long
    Dim j           As Long
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim row         As Long
    Dim Sorted      As Boolean
    Dim temp        As Variant
    Dim test        As Variant
    Dim Wks         As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set RngBeg = Wks.Range("A2")
        col = RngBeg.Column
        
        Set RngEnd = Wks.Cells(Rows.Count, col).End(xlUp)
        
            Set Entries = New Collection
            ReDim Items(0)
            
            For row = RngBeg.row To RngEnd.row
                Set Cell = Wks.Cells(row, col)
                    On Error Resume Next
                        test = Entries(Cell.Text)
                        If Err = 5 Then
                            Entries.Add index, Cell.Text
                            Items(index) = Cell.Text
                            index = index + 1
                            ReDim Preserve Items(index)
                        End If
                    On Error GoTo 0
            Next row
              
        index = index - 1
        Descending = False  ' Set this to True to sort in descending order Z-A.
        ReDim Preserve Items(index)
        
            Do
                Sorted = True
                
                For j = 0 To index - 1
                    If Descending Xor StrComp(Items(j), Items(j + 1), vbTextCompare) = 1 Then
                        temp = Items(j + 1)
                        Items(j + 1) = Items(j)
                        Items(j) = temp
                        
                        Sorted = False
                    End If
                Next j
                
                index = index - 1
            Loop Until Sorted Or index < 1
                   
        ComboBox1.List = Items
        
End Sub

 

[powerpivotlegal]

Thanks Leith. Everything seems to be working with all my other code and command buttons. I'll post my other queries for my UserForm in a separate thread.

 

[Leith Ross]

Hello pivotpowerlegal,

You're welcome. Good to hear everything is working well for you.