My ListBox Sort Macro to Share

[donwiss]

I needed a macro to sort my ListBoxes. So I developed the following from various web sources:

Sub SortListBox(myListBox As Control, Optional SortCol As Integer)
' sorts a MultiColumn ListBox. always does two sorts:
'   when sort is on column 0, then secondary sort is on column 1
'   when sort is on a column other than 0, then secondary sort is on column 0
' if sort column VarType is Date, then sort is descending
' if sort column VarType is String, then test is case insensitive
' SortCol defaults to 0, or first column

    Dim LbList As Variant

' store the list in a working array for sorting
    LbList = myListBox.List

' do the sort
    LbList = BubbleSort(LbList, SortCol)

' when first column, we secondary sort on second column
    If SortCol = 0 Then
        LbList = BubbleSort(LbList, 1, 0)

' when primary sort was another column, we secondary sort on first column
    Else
        LbList = BubbleSort(LbList, 0, SortCol)
    End If

' remove the contents of the ListBox (needed?)
    myListBox.Clear

' repopulate with the sorted list
    myListBox.List = LbList

End Sub

Function BubbleSort(myArray As Variant, SortCol As Integer, Optional Key1 As Variant) As Variant
' written as a sub macro to SortListBox, but can also be used stand alone. e.g. before initial fill in of ListBox
' turn on Key1 for second sort (for third sort would have to test against three keys)

    Dim FirstSort, isDate, isString, test As Boolean
    Dim i, j, k As Integer
    Dim temp As Variant

    FirstSort = IsMissing(Key1)
    If FirstSort Then Key1 = 0

' when strings, we make case insensitive
    isString = VarType(myArray(0, SortCol)) = vbString
' when dates, sort is descending
    isDate = VarType(myArray(0, SortCol)) = vbDate

' bubble sort the array
    For i = 0 To UBound(myArray, 1) - 1
        For j = i + 1 To UBound(myArray, 1)
' when we are doing a secondary sort, only sort needed rows. For 3 add: And myArray(i, Key2) = myArray(j, Key2)
            If FirstSort Or myArray(i, Key1) = myArray(j, Key1) Then
' capitalize when strings
                If isString Then
                    test = UCase(myArray(i, SortCol)) > UCase(myArray(j, SortCol))
' descending when dates
                ElseIf isDate Then
                    test = myArray(i, SortCol) < myArray(j, SortCol)
' numbers
                Else
                    test = myArray(i, SortCol) > myArray(j, SortCol)
                End If
' swap values in all columns
                If test Then
                    For k = 0 To UBound(myArray, 2)
                        temp = myArray(i, k)
                        myArray(i, k) = myArray(j, k)
                        myArray(j, k) = temp
                    Next k
                End If
            End If
        Next j
    Next i
    BubbleSort = myArray

End Function

I found the simplest way to implement sorting was with small sort buttons. One click for the user. Simple code for me. Bolding the sorted column title gives a simple visible indication. The ListBox is filled from Access.

The sort buttons are labels with these settings:

.Caption = "Sort"
.Height = 15
.SpecialEffect = fmSpecialEffectRaised
.TextAlign = fmTextAlignCenter
.Width = 24

Optional:

.TabStop = True

I have this code behind:

Private Sub bnSort1_Click()
    SortListBox ListBox1, 0
    SortLabel 1
End Sub

Private Sub SortLabel(ColOn As Integer, Optional SkipSave As Boolean)
' set SkipSave to True when initializing form
    Dim i As Integer
    For i = 1 To 5
        Me.Controls("Label" & i).Font.Bold = i = ColOn
    Next i
' save the changed new order
    If SkipSave Then Exit Sub
    SaveRegKeyValue "PriceSweepDisplay5", ColOn
End Sub

Now that has saving the sort choice to the user's Registry. All my sort choices and form locations are saved in the Registry. I recommend storing settings in the Registry. You can remove the code in my macro here.

I mentioned above filling the ListBox from Access. I have this function for that:

Function FlipData(Mat As Variant) As Variant
' transposes data in a matrix. useful when retrieving from Access

    If IsEmpty(Mat) Then Exit Function

    Dim i, j, NumI, NumJ As Integer
    Dim data As Variant
    
    NumI = UBound(Mat, 1)
    NumJ = UBound(Mat, 2)

    ReDim data(NumJ, NumI)
    For i = 0 To NumI
        For j = 0 To NumJ
            data(j, i) = Mat(i, j)
        Next j
    Next i
    FlipData = data

End Function

 

[dmt32]

Hi
Thanks for sharing - just a comment on your some of your variable declarations

When declaring variables, you need to explicitly declare each one with its data type even if they are all on same line

For example, these two lines from your function - only the last variable in each line is of boolean or integer data types which I assume is your intention?, the rest are all variants

    Dim FirstSort, isDate, isString, test As Boolean
    Dim i, j, k As Integer

should be:

    Dim FirstSort As Boolean, isDate As Boolean, isString As Boolean, test As Boolean
    Dim i As Integer, j As Integer, k As Integer

Hope Helpful

Dave

 

[donwiss]

Oh! Thank you very much. I did not realize this. I now have hundreds of places to fix.

There is also a shortcoming with the main macro. A test needs to be added, so that it doesn't try to sort the second column when there is ony one. Though when only one column, I would simply pass the variable through the BubbleSort function.

 

[donwiss]

I've made some upgrades to my sort routines, so I figured I'd add them to the thread.

(1) As noted previously, it needs to test when only one column.
(2) I keep my dates in strings, either an empty string or valid date. The detection of the type of data in the sort column has been enhanced to find these.
(3) I added a flag to flip the default sort direction for dates and numbers. This allows one to toggle these columns back and forth between the two sort directions. Code is below. But first the enhanced code:

Sub SortListBox(myListBox As Control, Optional SortCol As Integer, Optional FlipDirFlag As Boolean)
' sorts a MultiColumn ListBox. always does two sorts:
'   when sort is on column 0, then secondary sort is on column 1
'   when sort is on a column other than 0, then secondary sort is on column 0
' if sort column VarType is Date, then sort is descending
' if sort column VarType is String, then test is case insensitive
' SortCol defaults to 0, or first column
' the FlipDirFlag can be used when the date or number sort is pressed to toggle between sort directions

    Dim myArray As Variant

    If myListBox.ListCount = 0 Then Exit Sub
' store the list in a working array for sorting
    myArray = myListBox.List

' do the sort
    myArray = BubbleSort(myArray, SortCol, , FlipDirFlag)

' when first column, we secondary sort on second column
    If myListBox.ColumnCount > 1 Then
        If SortCol = 0 Then
            myArray = BubbleSort(myArray, 1, 0, FlipDirFlag)

' when primary sort was another column, we secondary sort on first column
        Else
            myArray = BubbleSort(myArray, 0, SortCol, FlipDirFlag)
        End If
    End If

' remove the contents of the ListBox (needed?)
    myListBox.Clear
' repopulate with the sorted list
    myListBox.List = myArray

End Sub

Function BubbleSort(myArray As Variant, SortCol As Integer, Optional Key1 As Variant, Optional FlipDirFlag As Boolean) As Variant
' written as a sub function to SortListBox, but can also be used stand alone.
' turn on Key1 for second sort (for third sort would have to test against three keys)
' the FlipDirFlag can be used when the date or number sort is pressed to toggle between sort directions

    Dim FirstSort As Boolean, isDateVB As Boolean, isDateStr As Boolean, isString As Boolean, test As Boolean
    Dim i As Integer, j As Integer, k As Integer
    Dim temp As Variant

    FirstSort = IsMissing(Key1)
    If FirstSort Then Key1 = 0

' when strings, we make case insensitive
    isString = VarType(myArray(0, SortCol)) = vbString
' when dates, sort is descending by default
' sometimes they are real dates, and sometimes strings (hence the cleanup line)
' you can run DateValue on a Date data type, but it strips off the time
' the date test is also at end of array in case blanks sorted to top
    isDateVB = isDate(myArray(0, SortCol)) Or isDate(myArray(UBound(myArray, 1), SortCol))
    If isString And isDateVB Then
        isDateStr = True
        isString = False
        isDateVB = False
    End If

' bubble sort the array
    For i = 0 To UBound(myArray, 1) - 1
        For j = i + 1 To UBound(myArray, 1)
' when we are doing a secondary sort, only sort needed rows. For 3 add: And myArray(i, Key2) = myArray(j, Key2)
            If FirstSort Or myArray(i, Key1) = myArray(j, Key1) Then
' ~~ capitalize when strings
                If isString Then
                    test = UCase(myArray(i, SortCol)) > UCase(myArray(j, SortCol))
' ~~ dates ~~
' switch to ascending when string dates and flag was set
                ElseIf isDateStr And FlipDirFlag Then
                    test = DateValue(DefaultEmptyDate(myArray(i, SortCol), True)) > DateValue(DefaultEmptyDate(myArray(j, SortCol), True))
' normally descending when string dates
                ElseIf isDateStr Then
                    test = DateValue(DefaultEmptyDate(myArray(i, SortCol))) < DateValue(DefaultEmptyDate(myArray(j, SortCol)))
' switch to ascending when dates and flag was set
                ElseIf isDateVB And FlipDirFlag Then
                    test = myArray(i, SortCol) > myArray(j, SortCol)
' normally descending when dates
                ElseIf isDateVB Then
                    test = myArray(i, SortCol) < myArray(j, SortCol)
' ~~ numbers ~~
' switch to numbers in descending sort when flag set
                ElseIf FlipDirFlag Then
                    test = myArray(i, SortCol) < myArray(j, SortCol)
' normally numbers are ascending
                Else
                    test = myArray(i, SortCol) > myArray(j, SortCol)
                End If
' ~~ swap values in all columns
                If test Then
                    For k = 0 To UBound(myArray, 2)
                        temp = myArray(i, k)
                        myArray(i, k) = myArray(j, k)
                        myArray(j, k) = temp
                    Next k
                End If
            End If
        Next j
    Next i
    BubbleSort = myArray

End Function

Function DefaultEmptyDate(ByVal DateIn As String, Optional MaxDate As Boolean) As String
    If DateIn = "" Then
        If MaxDate Then
            DefaultEmptyDate = "12/31/3900"
        Else
            DefaultEmptyDate = "1/1/1900"
        End If
    Else
        DefaultEmptyDate = DateIn
    End If
End Function

To implement Sort Toggling we need a semi-global for each column that sort toggles. Toggling for alpha-sorted was not implemented, as it made no sense, and would create a lot more toggle flags. Up top (repeat for other flags):

Private DateAscendFlag As Boolean

In the Initialize macro after writing to the ListBox and sorting (repeat for other flags):

' if initial sort is date, we started descending by default, so we turn flag on for next time
    DateAscendFlag = SortOrder = 3

For the buttons we are not toggling:

Private Sub bnSort1_Click()
    SortListBox ListBox1, 0
    DateAscendFlag = False
    SortLabel 1
End Sub

For the column we are toggling:

Private Sub bnSort3_Click()
    SortListBox ListBox1, 2, DateAscendFlag
    DateAscendFlag = Not DateAscendFlag
    SortLabel 3
End Sub

Repeat in all the sort click events for each column that is toggling.