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.
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:
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