Solved: Building Dynamic List for Combobox Sort Alphabetically?

[Simon Lloyd]

Hi all, when you build a dynamic list for a combobox is it possible to sort the list alphabetically before passsing the array to the combobox?

The data that the list is built from cannot e sorted alphabetically as they are already sorted by date order.

Any ideas?

Regards,
SImon

[mdmackillop]

Hi Simon,
Have a look at http://vbaexpress.com/kb/getarticle.php?kb_id=103

[Simon Lloyd]

Thanks Malcom i will, at the moment i am using a function found on the MS Kb:

Function SelectionSort(TempArray As Variant)
Dim MaxVal As Variant
Dim MaxIndex As Integer
Dim i, j As Integer
' Step through the elements in the array starting with the
' last element in the array.
For i = UBound(TempArray) To 1 Step -1
' Set MaxVal to the element in the array and save the
' index of this element as MaxIndex.
MaxVal = TempArray(i)
MaxIndex = i
' Loop through the remaining elements to see if any is
' larger than MaxVal. If it is then set this element
' to be the new MaxVal.
For j = 1 To i
If TempArray(j) > MaxVal Then
MaxVal = TempArray(j)
MaxIndex = j
End If
Next j
' If the index of the largest element is not i, then
' exchange this element with element i.
If MaxIndex < i Then
TempArray(MaxIndex) = TempArray(i)
TempArray(i) = MaxVal
End If
Next i
End Function
Sub SelectionSortMyArray()
Dim TheArray As Variant
Dim i
' Create the array.
TheArray = Array("one", "two", "three", "four", "five", "six", _
"seven", "eight", "nine", "ten")
' Sort the Array and display the values in order.
SelectionSort TheArray
For i = 1 To UBound(TheArray)
MsgBox TheArray(i)
Next i
End Sub

a small amount of modification and it works, however it is sorting 1 name to the top of the list the name is Mary so should be under M but its probably something i have done...will sort that out.

I will check the link and post back!

Regards,
Simon

[Simon Lloyd]

Malcom, thanks for the links, they relate to "Bubble Sort" which reportedly can be quite slow if you have a lot of data, the method i posted is a selection sort, both can be found here http://support.microsoft.com/kb/q133135/

Regards,
SImon

[mdmackillop]

Hi Simon
I had a look at my old KB item and decided it needed un update. Here's the sample I'll be resubmitting. It's a lot simpler and more efficient. Just shows what I've picked up since I started here.

[Bob Phillips]

Here is a QuickSort, which does what it says on the tin.



Sub QuickSort(SortArray, L, R)
Dim i, j, X, Y
i = L
j = R
X = SortArray((L + R) / 2, LBound(SortArray, 2))

While (i <= j)
While (SortArray(i, LBound(SortArray, 2)) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, LBound(SortArray, 2)) And j > L)
j = j - 1
Wend
If (i <= j) Then
Y = SortArray(i, LBound(SortArray, 2))
SortArray(i, LBound(SortArray, 2)) = SortArray(j,
LBound(SortArray, 2))
SortArray(j, LBound(SortArray, 2)) = Y
i = i + 1
j = j - 1
End If
Wend
If (L < j) Then Call QuickSort(SortArray, L, j)
If (i < R) Then Call QuickSort(SortArray, i, R)
End Sub

The L and R arguments are the array bounds, it could be done in the sort routine.

[mdmackillop]

Using SelectionSort

Option Explicit
Option Base 1

Private Sub UserForm_Initialize()
Dim i As Long
Dim MyList As Range
Dim cel As Range
Dim d As Variant, It As Variant, a As Variant

Set d = CreateObject("Scripting.Dictionary")
Set MyList = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

'Create list of unique items using a Dictionary object
On Error Resume Next
For Each It In MyList
d.Add It.Value, It.Value 'Add keys and items
Next

'Create an array of unique items
a = d.Items
'Sort the array
ComboBox1.List() = SelectionSort(a)
End Sub

Private Sub CommandButton1_Click()
Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1) = ComboBox1
Unload UserForm1
End Sub

Function SelectionSort(TempArray As Variant) As Variant
Dim MaxVal As Variant
Dim MaxIndex As Integer
Dim i, j As Integer

' Step through the elements in the array starting with the
' last element in the array.
For i = UBound(TempArray) To 1 Step -1

' Set MaxVal to the element in the array and save the
' index of this element as MaxIndex.
MaxVal = TempArray(i)
MaxIndex = i

' Loop through the remaining elements to see if any is
' larger than MaxVal. If it is then set this element
' to be the new MaxVal.
For j = 1 To i
If TempArray(j) > MaxVal Then
MaxVal = TempArray(j)
MaxIndex = j
End If
Next j

' If the index of the largest element is not i, then
' exchange this element with element i.
If MaxIndex < i Then
TempArray(MaxIndex) = TempArray(i)
TempArray(i) = MaxVal
End If
Next i
SelectionSort = TempArray
End Function

[mdmackillop]

Time for a speed test?

[Simon Lloyd]

LOL!, duelling experts! Malcom on 5000 lines the code you posted had no visible speed difference to mine (i don't know how to time an event!), Bob i have to confess i didn't understand your code so i didn't know how to incorporate it in my workbook, LBound is that used when Excel already knows the variables or is that UBound? i'm not sure. I have looked at your code a few times now and i'm befuddled (no rss feed for that one!), there is no doubt that your code will do the Ronseal advert justice but for an inexperienced VBA'er like me it may as well be swahili....LOL

Regards,
SImon

[mdmackillop]

Here's QuickSort, which is 20 times faster in my test on 10,000 lines
Option Explicit

Private Sub UserForm_Initialize()
Dim i As Long
Dim MyList As Range
Dim cel As Range
Dim d As Variant, It As Variant, a As Variant

Set d = CreateObject("Scripting.Dictionary")
Set MyList = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

'Create list of unique items using a Dictionary object
On Error Resume Next
For Each It In MyList
d.Add It.Value, It.Value 'Add keys and items
Next

'Create an array of unique items
a = d.Items
'Sort the array
Quick_Sort a, 0, UBound(a)
ComboBox1.List() = a

End Sub

Private Sub CommandButton1_Click()
Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1) = ComboBox1
Unload UserForm1
End Sub


Private Sub Quick_Sort(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = First
High = Last
List_Separator = SortArray((First + Last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (First < High) Then Quick_Sort SortArray, First, High
If (Low < Last) Then Quick_Sort SortArray, Low, Last
End Sub

[Simon Lloyd]

Malcom, i like your attachment, mainly due to the fact of the add to list if not there (i didn't think of that, not like me really to be unimaginative!), running the sort in your workbook does take marginally longer than the SelectionSort both you and I posted!

[Simon Lloyd]

I see you're incorporating some "xld" technology there Malcom....can i ask how you know it's 20 times faster?

[mdmackillop]

Private Sub UserForm_Initialize()
Dim i As Long
Dim MyList As Range
Dim cel As Range
Dim d As Variant, It As Variant, a As Variant
Dim tim As Long

tim = Timer

Set d = CreateObject("Scripting.Dictionary")
Set MyList = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

'Create list of unique items using a Dictionary object
On Error Resume Next
For Each It In MyList
d.Add It.Value, It.Value 'Add keys and items
Next

'Create an array of unique items
a = d.Items

'Choose the method
'Call BubbleSort(a)
'ComboBox1.List() = a

'or
'ComboBox1.List() = SelectionSort(a)

'or
Quick_Sort a, 0, UBound(a)
ComboBox1.List() = a

Cells(2, 4) = "Time"
Cells(Rows.Count, 4).End(xlUp).Offset(1) = Timer - tim

End Sub

[Bob Phillips]

I said it does what it says on the tin :)

[mdmackillop]

:bow:

[johnske]

Can anyone play this game? - (~ 20 to 30 times faster than QuickSort on 10,000 lines :))

Option Explicit
'
Private Sub UserForm_Initialize()
'
Dim N As Long
'
Application.ScreenUpdating = False
'
'assuming data is on Sheet1 and column C is an unused column (change to suit)
With Sheet1
.Range("A1", .Range("A" & Rows.Count).End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Columns("C:C"), _
Unique:=True
'
.Range("C1", .Range("C" & Rows.Count).End(xlUp)).Sort _
Key1:=.Range("C2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
For N = 1 To .Range("C" & Rows.Count).End(xlUp).Row
ComboBox1.AddItem .Range("C" & N)
Next
.Range("C1", .Range("C" & Rows.Count).End(xlUp)).ClearContents
End With
Application.ScreenUpdating = True
'
End Sub

[Aussiebear]

Scatter everyone, there's a code fight at forum at noon....:devil2:

[mdmackillop]

'assuming data is on Sheet1 and column C is an unused column (change to suit)

This needs user intervention. To be fair, you'll need to find space programatically, without changing UsedRange which could impact elsewhere, or add a worksheet to manipulate your data.:slingshot

[csmith222]

BIG PROPS FOR THIS! Helped me out a lot!


Here's QuickSort, which is 20 times faster in my test on 10,000 lines
Option Explicit

Private Sub UserForm_Initialize()
Dim i As Long
Dim MyList As Range
Dim cel As Range
Dim d As Variant, It As Variant, a As Variant

Set d = CreateObject("Scripting.Dictionary")
Set MyList = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

'Create list of unique items using a Dictionary object
On Error Resume Next
For Each It In MyList
d.Add It.Value, It.Value 'Add keys and items
Next

'Create an array of unique items
a = d.Items
'Sort the array
Quick_Sort a, 0, UBound(a)
ComboBox1.List() = a

End Sub

Private Sub CommandButton1_Click()
Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1) = ComboBox1
Unload UserForm1
End Sub


Private Sub Quick_Sort(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = First
High = Last
List_Separator = SortArray((First + Last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (First < High) Then Quick_Sort SortArray, First, High
If (Low < Last) Then Quick_Sort SortArray, Low, Last
End Sub

[snb]

You can have a look over here:
1-dimensional array

http://www.snb-vba.eu/VBA_Combobox.html#L_13.1.4

and
2-dimensional array, >1 sorting criterion

http://www.snb-vba.eu/VBA_Combobox.html#L_13.2.2