3
\$\begingroup\$

I've been struggling to write a QuickSort algorithm to sort multiple columns of an Array for weeks. Finally, I decided to write a class that Implements mscorlib.IComparer and it has exceeded my expectations.

Ironically, my testing reveals that mscorlib.ArrayList itself uses a QuickSort algorithm. I concluded this by studying the order in which items were compared.

Download File

This code will add then mscorlib reference to your project. It is interesting that the reference description is Common Language Runtime Library.

  ThisWorkbook.VBProject.References.AddFromGuid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 1, 0

This simple test demonstrates how to use the class.

Sub SimpleTest()
    ' Initialize Sorter and add 3 columns with mixed Sort Orders
    Dim Sorter As New DataManager
    Sorter.AddColumn 3, xlDescending
    Sorter.AddColumn 1, xlAscending
    Sorter.AddColumn 4, xlAscending

    ' Fill Array of Values
    Dim Values
    Values = Range("A1").CurrentRegion.Value

    ' Test if the values are correctly sorted
    Debug.Print "Before: "; Sorter.isSorted(Values:=Values, HasHeaders:=True)

    'Actual Usage
    Sorter.Sort Values:=Values, HasHeaders:=True

  '  Stop
    ' Test if the values are correctly sorted
    Debug.Print "After: "; Sorter.isSorted(Values:=Values, HasHeaders:=True)

    Workbooks.Add
    Range("A1").Resize(UBound(Values), 4) = Values
End Sub

Class: DataManager

Attribute VB_Name = "DataManager"
Attribute VB_PredeclaredId = False

Option Explicit

Implements mscorlib.IComparer

Private Type Members
    Values As Variant
End Type

Private m As Members

Private Type ColumnParameters
    ColumnIndex As Long
    Compare As VbCompareMethod
    SortOrder As XlSortOrder
End Type

Private Columns() As ColumnParameters

Private Type SortVariables
    c As Long
    Index As Long
    r As Long
    list As New ArrayList
    Values As Variant
End Type

Private Type isSortedVariables
    r As Long
    result As Long
End Type

Public Sub AddColumn(ByVal ColumnIndex As Long, Optional ByVal SortOrder As XlSortOrder = xlAscending, Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)

    If ColumnExists(ColumnIndex) Then
        Err.Raise Number:=vbObjectError + 513, Description:="Column Exists"
    End If

    ReDim Preserve Columns(0 To ColumnCount)

    With Columns(ColumnCount - 1)
        .ColumnIndex = ColumnIndex
        .Compare = .Compare
        .SortOrder = SortOrder
    End With
End Sub

Public Function ColumnExists(ByVal ColumnIndex As Long) As Boolean
    Dim n As Long
    For n = 0 To ColumnCount - 1
        With Columns(n)
            If .ColumnIndex = ColumnIndex Then
                ColumnExists = True
                Exit Function
            End If
        End With
    Next
End Function

Private Function GetColumn(ByVal ColumnIndex As Long) As ColumnParameters
    If ColumnExists(ColumnIndex) Then
        Dim n As Long
        For n = 0 To ColumnCount - 1
            With Columns(n)
                If .ColumnIndex = ColumnIndex Then
                    GetColumn = Columns(n)
                    Exit Function
                End If
            End With
        Next
    End If
End Function

Public Function IComparer_Compare(ByVal X As Variant, ByVal Y As Variant) As Long
    Dim n As Long, result As Long
    Dim s1 As Variant, s2 As Variant

    For n = 0 To ColumnCount - 1
        With Columns(n)
            s1 = m.Values(X, .ColumnIndex)
            s2 = m.Values(Y, .ColumnIndex)

            If (IsDate(s1) And IsDate(s2)) Then
                If DateValue(s1) < DateValue(s2) Then
                    result = -1
                ElseIf DateValue(s1) > DateValue(s2) Then
                    result = 1
                End If
            ElseIf (IsNumeric(s1) And IsNumeric(s2)) Then
                If Val(s1) < Val(s2) Then
                    result = -1
                ElseIf Val(s1) > Val(s2) Then
                    result = 1
                End If
            Else
                result = StrComp(s1, s2, .Compare)
            End If

            If .SortOrder = xlDescending Then result = result * -1

            If result <> 0 Then Exit For
        End With
    Next

    IComparer_Compare = result
End Function

Public Function isSorted(ByRef Values, Optional ByVal HasHeaders As Boolean) As Boolean
    Dim h As isSortedVariables
    m.Values = Values

    For h.r = IIf(HasHeaders, LBound(Values) + 1, LBound(Values)) To UBound(Values) - 1
        h.result = IComparer_Compare(h.r, h.r + 1)
        If h.result > 0 Then
            Erase m.Values
            Exit Function
        End If
    Next
    Erase m.Values
    isSorted = True
End Function

Public Sub Sort(ByRef Values, Optional ByVal HasHeaders As Boolean)
    m.Values = Values

    Dim h As SortVariables

    For h.Index = LBound(Values) To UBound(Values)
        h.list.Add CStr(h.Index)
    Next


    h.list.Sort_2 Me

    If HasHeaders Then
        h.list.RemoveAt h.list.IndexOf(CStr(LBound(Values)), 0)
        h.list.Insert 0, CStr(LBound(Values))
    End If

    ReDim h.Values(LBound(Values) To UBound(Values), LBound(Values, 2) To UBound(Values, 2))
    For h.r = LBound(Values) To UBound(Values)
        h.Index = h.list(h.r - 1)
        For h.c = LBound(Values, 2) To UBound(Values, 2)
            h.Values(h.r, h.c) = Values(h.Index, h.c)
        Next
    Next

    Values = h.Values
    Erase m.Values
End Sub

Public Sub ColumnClear()
    Erase Columns
End Sub

Public Function ColumnCount() As Long
    If (Not Not Columns) <> 0 Then ColumnCount = UBound(Columns) + 1
End Function

Module: UnitTest

Attribute VB_Name = "UnitTest"
Option Explicit

Public Enum OrderColumns
    [Row ID] = 1
    [Order ID]
    [Order Date]
    [Ship Date]
    [Ship Mode]
    [Customer ID]
    [Customer Name]
    [Segment]
    [Country]
    [City]
    [State]
    [Postal Code]
    [Region]
    [Product ID]
    [Category]
    [Sub-Category]
    [Product Name]
    [Sales]
    [Quantity]
    [Discount]
    [Profit]
End Enum
Private DeleteTestWorkbooks As Boolean

Private Type TestResults
    Description As String
    ElaspseTime As String
    n As Long
    WasSorted As Boolean
    Passed As Boolean
    RowCount As Long
    Sorter As New DataManager
    Stopwatch As New Stopwatch
    Values As Variant
End Type

Private Sub AddTestWorkbook(ByVal Description As String, Values)
    Workbooks.Add

    Range("A1").Value = Description

    Range("A3").Resize(UBound(Values), UBound(Values, 2)).Value = Values
    Columns.AutoFit

End Sub

Private Sub CloseActiveTestWorkbook()
    If Len(ActiveWorkbook.Path) = 0 Then ActiveWorkbook.Close False
End Sub

Private Sub CloseTestWorkbooks()
    Application.ScreenUpdating = False
    Dim wb As Workbook
    For Each wb In Workbooks
        If Len(wb.Path) = 0 Then wb.Close False
    Next
End Sub

Private Function getValues(ByVal RowCount As Long)
    If RowCount = 0 Then
        getValues = ThisWorkbook.Worksheets("Data").Range("A1").CurrentRegion.Value
    Else
        getValues = ThisWorkbook.Worksheets("Data").Range("A1").CurrentRegion.Resize(RowCount).Value
    End If
End Function

Private Function GetTestResults(ByVal Description As String, ByVal RowCount As Long, DoAddTestWorkbook As Boolean, ParamArray ColumnOrderPairs()) As TestResults
    Dim h As TestResults
    h.Description = Description

    Application.ScreenUpdating = False

    For h.n = 0 To UBound(ColumnOrderPairs) - 1 Step 2
        h.Sorter.AddColumn ColumnOrderPairs(h.n), ColumnOrderPairs(h.n + 1)
    Next

    h.Values = getValues(RowCount)
    h.RowCount = UBound(h.Values)

    h.WasSorted = h.Sorter.isSorted(h.Values, True)

    h.Stopwatch.Start
    h.Sorter.Sort h.Values, True
    h.Stopwatch.Start

    h.ElaspseTime = h.Stopwatch.ElaspseTimeToString(2)

    h.Passed = h.Sorter.isSorted(h.Values, True)
    If DoAddTestWorkbook Then AddTestWorkbook Description, h.Values

    GetTestResults = h
End Function

Private Sub TestSorter(Optional ByVal RowCount As Long, Optional ByVal DoAddTestWorkbook As Boolean)
    Const a = 12, b = 21, c = 33, d = 41
    ' RowCount = 0 will process all rows

    Debug.Print
    Debug.Print "RowCount"; Tab(a); "Time"; Tab(b); "Was Sorted"; Tab(c); "Passed"; Tab(d); "Description"

    With GetTestResults("[Ship Date], xlAscending", RowCount, DoAddTestWorkbook, [Ship Date], xlAscending)
        Debug.Print .RowCount; Tab(a); .ElaspseTime; Tab(b); .WasSorted; Tab(c); .Passed; Tab(d); .Description
    End With

    With GetTestResults("[Order Date], xlAscending, State, xlAscending, City, xlAscending", RowCount, DoAddTestWorkbook, [Order Date], xlAscending, State, xlAscending, City, xlAscending)
        Debug.Print .RowCount; Tab(a); .ElaspseTime; Tab(b); .WasSorted; Tab(c); .Passed; Tab(d); .Description
    End With

    With GetTestResults("9,1,2,3,4,5,6,7,8", RowCount, DoAddTestWorkbook, 9, xlAscending, 1, xlAscending, 2, xlAscending, 3, xlAscending, 4, xlAscending, 5, xlAscending, 6, xlAscending, 7, xlAscending, 8, xlAscending)
        Debug.Print .RowCount; Tab(a); .ElaspseTime; Tab(b); .WasSorted; Tab(c); .Passed; Tab(d); .Description
    End With

End Sub

Private Sub TestTimes()
    TestSorter "1,000", False
    TestSorter "10,000", False
    TestSorter "35,000", False
    TestSorter "70,000", False
    TestSorter 0, False
End Sub

Results

Immediate Window

I am 99%c certain that the data is being sorted properly because the second UnitTest.TestSorter test is in the same order that I sorted the worksheet before I ran the test. It is also the only test that shows the data was sorted properly before applying DataManaget.Sort.

The worksheet was sort one column at a time in ascending order: City, State and Order Date. The columns are added in reverse order: Order Date, State, and City by design.

With GetTestResults("[Order Date], xlAscending, State, xlAscending, City, xlAscending", RowCount, DoAddTestWorkbook, [Order Date], xlAscending, State, xlAscending, City, xlAscending)
    Debug.Print .RowCount; Tab(a); .ElaspseTime; Tab(b); .WasSorted; Tab(c); .Passed; Tab(d); .Description
End With

As always, I would appreciate any feedback. Did I miss anything. Are my tests off? Is there a better way to test it?

I'm sure that I will get some interesting comments on my use of custom Types to separate the variable declaration from the subroutine body. The idea comes from C++ usage of a header files. It is more an experiment than anything but I really really like it. The big advantage is that it reduces the variable declarations to a single simple declaration. The big drawback is it makes it hard to eliminate unused variables. Eh..I don;t know. Big declaration blocks suck and IMO declare as and where needed really suck. I'll probably get a million downvotes for this one. Ughh..Maybe I will get lucky and nobody will notice.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.