VBA Bubble Sort Algorithm Slow

Question

I am surprised at how slow this bubble sort algorithm is using VBA. So my question is am I doing something wrong/inefficient, or is this just the best VBA and bubble sort wi

Answer 1

First of all: don't use bubble sort on 5000 rows! It'll take 5000^2/2 iterations, i.e. 12.5B iterations! Better use a decent QuickSort algorithm. At the bottom of this post you'll find one that you could use as a starting point. It only compares column 1. On my system, the sorting of took 0.01s (instead of the 4s after optimization of bubble sort).

Now, for the challenge, check out the below code. It runs at ~30% of the original run time - and at the same time reduces the lines of code significantly.

The main levers were:

• Use Double instead of Variant for the main array (Variant always comes with some overhead in terms of memory management)
• Reduce the number of calls/handovers of variables - instead of using your subs CompareOne and CompareTwo, I inlined the code and optimized it. Also, I accessed the values directly without assigning them to a temp variable
• Just populating the array took 10% of the total time. Instead, I bulk assigned the array (had to switch rows & columns for that) and then casted it to a double array
• The speed could be further optimized by having two separate loops - one for one column and one for two columns. This reduces run time by ~10%, but bloats the code so left it out.

Option Explicit

Sub sortA()

    Dim start_time As Double
    Dim varArray As Variant, dblArray() As Double
    Dim a, b As Long

    Const rows As Long = 5000
    Const cols As Long = 3

    start_time = Timer
    'Copy everything to array of type variant
    varArray = ArraySheet.Range("A1").Resize(rows, cols).Cells

    'Cast variant to double
    ReDim dblArray(1 To rows, 1 To cols)
    For a = 1 To rows
        For b = 1 To cols
            dblArray(a, b) = varArray(a, b)
        Next b
    Next a


    BubbleSort dblArray, 1, False, 2, True

    MsgBox Format(Timer - start_time, "0.00")

End Sub

'Array Must Be: Array(Column,Row)
Sub BubbleSort(ThisArray() As Double, SortColumn1 As Long, Asc1 As Boolean, Optional SortColumn2 As Long = -1, Optional Asc2 As Boolean)

    Dim LastRow As Long
    Dim FirstCol As Long
    Dim LastCol As Long
    Dim lTemp As Double
    Dim i, j, k As Long
    Dim CompareResult As Boolean

    LastRow = UBound(ThisArray, 1)
    FirstCol = LBound(ThisArray, 2)
    LastCol = UBound(ThisArray, 2)

    For i = LBound(ThisArray, 1) To LastRow
        For j = i + 1 To LastRow
            If SortColumn2 = -1 Then    'If there is only one column to sort by
                CompareResult = ThisArray(i, SortColumn1) <= ThisArray(j, SortColumn1)
                If Asc1 Then CompareResult = Not CompareResult
            Else    'If there are two columns to sort by
                Select Case ThisArray(i, SortColumn1)
                    Case Is < ThisArray(j, SortColumn1): CompareResult = Not Asc1
                    Case Is > ThisArray(j, SortColumn1): CompareResult = Asc1
                    Case Else
                        CompareResult = ThisArray(i, SortColumn2) <= ThisArray(j, SortColumn2)
                        If Asc2 Then CompareResult = Not CompareResult
                End Select
            End If
            If CompareResult Then    ' If compare result returns true, Flip rows
                For k = FirstCol To LastCol
                    lTemp = ThisArray(j, k)
                    ThisArray(j, k) = ThisArray(i, k)
                    ThisArray(i, k) = lTemp
                Next k
            End If
        Next j
    Next i
End Sub

Here's a QuickSort implementation:

Public Sub subQuickSort(var1 As Variant, _
    Optional ByVal lngLowStart As Long = -1, _
    Optional ByVal lngHighStart As Long = -1)

    Dim varPivot As Variant
    Dim lngLow As Long
    Dim lngHigh As Long

    lngLowStart = IIf(lngLowStart = -1, LBound(var1), lngLowStart)
    lngHighStart = IIf(lngHighStart = -1, UBound(var1), lngHighStart)
    lngLow = lngLowStart
    lngHigh = lngHighStart

    varPivot = var1((lngLowStart + lngHighStart) \ 2, 1)

    While (lngLow <= lngHigh)
        While (var1(lngLow, 1) < varPivot And lngLow < lngHighStart)
            lngLow = lngLow + 1
        Wend

        While (varPivot < var1(lngHigh, 1) And lngHigh > lngLowStart)
            lngHigh = lngHigh - 1
        Wend

        If (lngLow <= lngHigh) Then
            subSwap var1, lngLow, lngHigh
            lngLow = lngLow + 1
            lngHigh = lngHigh - 1
        End If
    Wend

    If (lngLowStart < lngHigh) Then
        subQuickSort var1, lngLowStart, lngHigh
    End If
    If (lngLow < lngHighStart) Then
        subQuickSort var1, lngLow, lngHighStart
    End If

End Sub

Private Sub subSwap(var As Variant, lngItem1 As Long, lngItem2 As Long)
    Dim varTemp As Variant
    varTemp = var(lngItem1, 1)
    var(lngItem1, 1) = var(lngItem2, 1)
    var(lngItem2, 1) = varTemp
End Sub