VBA Bubble Sort Algorithm Slow - algorithm

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 will do? For instance, could using VARIANTs, too many variables, etc. be slowing performance substantially. I know Bubble Sort is not particularly fast, but I didn't think it would be this slow.
Algorithm inputs: 2D array and either one or two columns to sort by, each asc or desc.
I don't necessarily need lightning fast, but 30 seconds for 5,000 rows is completely unacceptable
Option Explicit
Sub sortA()
Dim start_time, end_time
start_time = Now()
Dim ThisArray() As Variant
Dim sheet As Worksheet
Dim a, b As Integer
Dim rows, cols As Integer
Set sheet = ArraySheet
rows = 5000
cols = 3
ReDim ThisArray(0 To cols - 1, 0 To rows - 1)
For a = 1 To rows
For b = 1 To cols
ThisArray(b - 1, a - 1) = ArraySheet.Cells(a, b)
Next b
Next a
Call BubbleSort(ThisArray, 0, False, 2, True)
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))
End Sub
'Array Must Be: Array(Column,Row)
Sub BubbleSort(ThisArray As Variant, SortColumn1 As Integer, Asc1 As Boolean, Optional SortColumn2 As Integer = -1, Optional Asc2 As Boolean)
Dim FirstRow As Integer
Dim LastRow As Integer
Dim FirstCol As Integer
Dim LastCol As Integer
Dim lTemp As Variant
Dim i, j, k As Integer
Dim a1, a2, b1, b2 As Variant
Dim CompareResult As Boolean
FirstRow = LBound(ThisArray, 2)
LastRow = UBound(ThisArray, 2)
FirstCol = LBound(ThisArray, 1)
LastCol = UBound(ThisArray, 1)
For i = FirstRow To LastRow
For j = i + 1 To LastRow
If SortColumn2 = -1 Then 'If there is only one column to sort by
a1 = ThisArray(SortColumn1, i)
a2 = ThisArray(SortColumn1, j)
If Asc1 = True Then
CompareResult = compareOne(a1, a2)
Else
CompareResult = compareOne(a2, a1)
End If
Else 'If there are two columns to sort by
a1 = ThisArray(SortColumn1, i)
a2 = ThisArray(SortColumn1, j)
b1 = ThisArray(SortColumn2, i)
b2 = ThisArray(SortColumn2, j)
If Asc1 = True Then
If Asc2 = True Then
CompareResult = compareTwo(a1, a2, b1, b2)
Else
CompareResult = compareTwo(a1, a2, b2, b1)
End If
Else
If Asc2 = True Then
CompareResult = compareTwo(a2, a1, b1, b2)
Else
CompareResult = compareTwo(a2, a1, b2, b1)
End If
End If
End If
If CompareResult = True Then ' If compare result returns true, Flip rows
For k = FirstCol To LastCol
lTemp = ThisArray(k, j)
ThisArray(k, j) = ThisArray(k, i)
ThisArray(k, i) = lTemp
Next k
End If
Next j
Next i
End Sub
Function compareOne(FirstCompare1 As Variant, FirstCompare2 As Variant) As Boolean
If FirstCompare1 > FirstCompare2 Then
compareOne = True
Else
compareOne = False
End If
End Function
Function compareTwo(FirstCompare1 As Variant, FirstCompare2 As Variant, SecondCompare1 As Variant, SecondCompare2 As Variant) As Boolean
If FirstCompare1 > FirstCompare2 Then
compareTwo = True
ElseIf FirstCompare1 = FirstCompare2 And SecondCompare1 > SecondCompare2 Then
compareTwo = True
Else
compareTwo = False
End If
End Function
Thanks a ton for any help or advice!!
Edit: I decided to used QuickSort instead. See post below for the code if interested.

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

Answer 2

My thoughts:
You really don't want to use an N^2 algorithm for anything that has more than 20-30 items (maximum). If you have 5000-10000 rows, starting with BubbleSort was a mistake, IMHO
VBA is unpredictable. Beyond ditching bubbleSort (just ask Barack Obama), you want to try different ways of doing things in VBA.
For example:
Replace for ... next loops with for ... each loops: the latter (paradoxically) can be faster
Try using variants versus immediately converting to primitive types and using those. It used to be the case that VBA handled Variants much faster, but YMMV.

Answer 3

Here is my implementation of quicksort for anyone interested. I am sure the code could be cleaned up quite a but, but here is a good start. This code sorted 10,000 rows in less then a second.
Option Explicit
' QuickSort for 2D array in form Array(cols,rows)
' Enter in 1, 2, or 3 columns to sort by, each can be either asc or desc
Public Sub QuickSortStart(ThisArray As Variant, sortColumn1 As Integer, asc1 As Boolean, Optional sortColumn2 As Integer = -1, Optional asc2 As Boolean = True, Optional sortColumn3 As Integer = -1, Optional asc3 As Boolean = True)
Dim LowerBound As Integer
Dim UpperBound As Integer
LowerBound = LBound(ThisArray, 2)
UpperBound = UBound(ThisArray, 2)
Call QuickSort(ThisArray, LowerBound, UpperBound, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End Sub
Private Sub QuickSort(ThisArray As Variant, FirstRow As Integer, LastRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
Dim pivot1 As Variant
Dim pivot2 As Variant
Dim pivot3 As Variant
Dim tmpSwap As Variant
Dim tmpFirstRow As Integer
Dim tmpLastRow As Integer
Dim FirstCol As Integer
Dim LastCol As Integer
Dim i As Integer
tmpFirstRow = FirstRow
tmpLastRow = LastRow
FirstCol = LBound(ThisArray, 1)
LastCol = UBound(ThisArray, 1)
pivot1 = ThisArray(sortColumn1, (FirstRow + LastRow) \ 2)
If sortColumn2 <> -1 Then
pivot2 = ThisArray(sortColumn2, (FirstRow + LastRow) \ 2)
End If
If sortColumn3 <> -1 Then
pivot3 = ThisArray(sortColumn3, (FirstRow + LastRow) \ 2)
End If
While (tmpFirstRow <= tmpLastRow)
While (compareFirstLoop(ThisArray, pivot1, pivot2, pivot3, tmpFirstRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3) And tmpFirstRow < LastRow)
tmpFirstRow = tmpFirstRow + 1
Wend
While (compareSecondLoop(ThisArray, pivot1, pivot2, pivot3, tmpLastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3) And tmpLastRow > FirstRow)
tmpLastRow = tmpLastRow - 1
Wend
If (tmpFirstRow <= tmpLastRow) Then
For i = FirstCol To LastCol
tmpSwap = ThisArray(i, tmpFirstRow)
ThisArray(i, tmpFirstRow) = ThisArray(i, tmpLastRow)
ThisArray(i, tmpLastRow) = tmpSwap
Next i
tmpFirstRow = tmpFirstRow + 1
tmpLastRow = tmpLastRow - 1
End If
Wend
If (FirstRow < tmpLastRow) Then
Call QuickSort(ThisArray, FirstRow, tmpLastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End If
If (tmpFirstRow < LastRow) Then
Call QuickSort(ThisArray, tmpFirstRow, LastRow, sortColumn1, asc1, sortColumn2, asc2, sortColumn3, asc3)
End If
End Sub
Private Function compareFirstLoop(ThisArray As Variant, pivot1 As Variant, pivot2 As Variant, pivot3 As Variant, checkRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
If asc1 = True And ThisArray(sortColumn1, checkRow) < pivot1 Then
compareFirstLoop = True
ElseIf asc1 = False And ThisArray(sortColumn1, checkRow) > pivot1 Then
compareFirstLoop = True
'Move to Second Column
ElseIf sortColumn2 <> -1 And ThisArray(sortColumn1, checkRow) = pivot1 Then
If asc2 = True And ThisArray(sortColumn2, checkRow) < pivot2 Then
compareFirstLoop = True
ElseIf asc2 = False And ThisArray(sortColumn2, checkRow) > pivot2 Then
compareFirstLoop = True
'Move to Third Column
ElseIf sortColumn3 <> -1 And ThisArray(sortColumn2, checkRow) = pivot2 Then
If asc3 = True And ThisArray(sortColumn3, checkRow) < pivot3 Then
compareFirstLoop = True
ElseIf asc3 = False And ThisArray(sortColumn3, checkRow) > pivot3 Then
compareFirstLoop = True
Else
compareFirstLoop = False
End If
Else
compareFirstLoop = False
End If
Else
compareFirstLoop = False
End If
End Function
Private Function compareSecondLoop(ThisArray As Variant, pivot1 As Variant, pivot2 As Variant, pivot3 As Variant, checkRow As Integer, sortColumn1 As Integer, asc1 As Boolean, sortColumn2 As Integer, asc2 As Boolean, sortColumn3 As Integer, asc3 As Boolean)
If asc1 = True And pivot1 < ThisArray(sortColumn1, checkRow) Then
compareSecondLoop = True
ElseIf asc1 = False And pivot1 > ThisArray(sortColumn1, checkRow) Then
compareSecondLoop = True
'Move to Second Column
ElseIf sortColumn2 <> -1 And ThisArray(sortColumn1, checkRow) = pivot1 Then
If asc2 = True And pivot2 < ThisArray(sortColumn2, checkRow) Then
compareSecondLoop = True
ElseIf asc2 = False And pivot2 > ThisArray(sortColumn2, checkRow) Then
compareSecondLoop = True
'Move to Third Column
ElseIf sortColumn3 <> -1 And ThisArray(sortColumn2, checkRow) = pivot2 Then
If asc3 = True And pivot3 < ThisArray(sortColumn3, checkRow) Then
compareSecondLoop = True
ElseIf asc3 = False And pivot3 > ThisArray(sortColumn3, checkRow) Then
compareSecondLoop = True
Else
compareSecondLoop = False
End If
Else
compareSecondLoop = False
End If
Else
compareSecondLoop = False
End If
End Function