I have the code below which is used to remove duplicates and sort the values alphabetically into a listbox within a userform but it is prioritizing uppercase over alphabetical and I would like it to ignore the case of the text
Dim Coll As Collection, cell As Range, LastRow As Long
Dim blnUnsorted As Boolean, i As Integer, temp As Variant
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Groups")
'///////////////////////////////////////////////////////
'Populate the ListBox with unique Make items from column A.
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
'Open a With structure for the ListBox control.
With ClientInput
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
'Only attempt to populate cells containing a text or value.
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
blnUnsorted = True
Do
blnUnsorted = 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
blnUnsorted = True
Exit For
End If
Next i
Loop While blnUnsorted = True
'Close the With structure for the ListBox control.
End With
Current
AC
AZ
ab
Desired
ab
AC
AZ
CodePudding user response：
You can use the worksheetfunction sort
This is a sample code of how to use it
Sub sortRange()
Dim rg As Range: Set rg = Selection
Dim arrValues As Variant
arrValues = WorksheetFunction.Sort(rg)
rg.Offset(, 2).Resize(3).Value = arrValues
End Sub
If A1:A3 are selected the above code will write the sorted values to C1:C3
You can iterate over the array to add the items to the list
CodePudding user response：
Instead of
If .List(i) > .List(i 1) Then
use
If LCase(.List(i)) > LCase(.List(i 1)) Then
CodePudding user response：
Please, try the next code. It firstly places the existing range (from A:A) in an array, sorts the range in place, places the sorted range in another array, extract unique strings (case sensitive) using a Dictionary and load the list box directly from the array using its List property. Then, places back the initial extracted array before sorting:
Sub UniqueSortLoadListBox()
Dim sh As Worksheet, lastR As Long, arr, arrSort, i As Long, dict As Object
Set sh = Worksheets("Groups")
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).Value
With sh.Sort 'the fastest sorting way
.SortFields.Clear
.SortFields.Add2 Key:=sh.Range("A1:A" & lastR), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange sh.Range("A1:A" & lastR)
.Header = xlYes
.MatchCase = True
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row ' recalculate to eliminate the empty cells
arrSort = sh.Range("A2:A" & lastR).Value 'place the sorted range in an array, for faster iteration/processing
'extract unique strings (case sensitive)
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = BinaryCompare 'case sensitive for keys creation
For i = 1 To UBound(arrSort)
dict(arrSort(i, 1)) = 1
Next i
'load the listbox directly from an array (dictionary keys array)
With clientInput
.Clear
.List = dict.Keys
End With
'place back the array as it was before sorting and unique extracting:
sh.Range("A2").Resize(UBound(arr), 1).Value = arr
End Sub
Please, send some feedback after testing it.
CodePudding user response：
Sorted Column Values to a List Box
If You Don't Have 365
- In a nutshell, the code will write the values from the criteria column to a helper column, the column adjacent to the right of the used range, sort it, retrieve its values, clear its contents, and populate a list box with the retrieved unique (sorted) values.
Sub PopulateClientInput()
Const ProcTitle As String = "Populate Client Input"
' Define constants.
Const wsName As String = "Groups"
Const cCol As Long = 1
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' It is assumed that the worksheet's used range consists of a valid table
' (not an Excel table) i.e. one row of headers and contiguous data below.
' Reference the expanded data range ('rg') i.e. the data range (no headers)
' and an extra helper column to the right. Retrieve the range's
' number of rows ('rCount') and columns ('cCount').
Dim rg As Range
Dim rCount As Long
Dim cCount As Long
With ws.UsedRange
rCount = .Rows.Count - 1 ' shrink
If rCount = 0 Then ' only headers or empty worksheet
MsgBox "Not enough rows.", vbExclamation, ProcTitle
Exit Sub
End If
cCount = .Columns.Count 1 ' expand
' Note that the following cannot happen if 'cCol = 1'.
If cCount < cCol 1 Then ' criteria column not in used range
MsgBox "Not enough columns.", vbExclamation, ProcTitle
Exit Sub
End If
' Reference the range.
Set rg = .Resize(rCount, cCount).Offset(1)
End With
' Reference the criteria column range ('crg').
Dim crg As Range: Set crg = rg.Columns(cCol)
' Store the sorted values from the criteria column range
' in a 2D one-based (one-column) array, the criteria array ('cData').
Application.ScreenUpdating = False
Dim cData() As Variant
If rCount > 1 Then ' multiple cells
' Reference the helper column range ('hrg').
Dim hrg As Range: Set hrg = rg.Columns(cCount)
' Write the values from the criteria column range
' to the helper column range.
hrg.Value = crg.Value
' Sort the helper column range.
hrg.Sort hrg, xlAscending, , , , , , xlNo
' Store the sorted values from the sorted helper column range
' in the criteria array.
cData = hrg.Value
' Clear the contents of the helper column range.
hrg.ClearContents
Else ' one cell
' Store the single value in the single element of the criteria array.
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
End If
' Store the unique values from the criteria array in the 'keys'
' of a dictionary ('dict').
' The 'items' are irrelevant but will hold 'Empty'.
' Error values and blanks are excluded.
' Define the dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
Dim cKey As Variant ' Current Value in the Criteria Array
Dim r As Long ' Current Row in the Criteria Array
' Store the unique valus in the dictionary.
For r = 1 To rCount
cKey = cData(r, 1) ' retrieve the current value
If Not IsError(cKey) Then ' exclude error values
If Len(CStr(cKey)) > 0 Then ' exclude blanks
' Check if the current value exists in the dictionary.
' This is not necessary but will ensure that the first occuring
' string's case is used. Otherwise, the last would be used.
If Not dict.Exists(cKey) Then
dict(cKey) = Empty ' store the unique value in a 'key'
End If
End If
End If
Next r
' Populate the list box with the sorted unique values
' from the dictionary and inform.
With ClientInput
' Validate the dictionary.
If dict.Count = 0 Then
.Clear ' or not?
Application.ScreenUpdating = True
MsgBox "No valid data.", vbExclamation, ProcTitle
Exit Sub
End If
.List = dict.Keys ' 'dict.Keys' is a zero-based (1D) array
Application.ScreenUpdating = True
MsgBox "Client input populated.", vbInformation, ProcTitle
End With
End Sub