VBA Bubble Sort Algorithm Slow

问题:

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.

回答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

回答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.

回答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