vba VBA冒泡排序算法慢

VBA Bubble Sort Algorithm Slow

提问by TheBigC

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.

我很惊讶这种冒泡排序算法使用 VBA 的速度有多慢。所以我的问题是我做错了什么/效率低下，还是这只是最好的 VBA 和冒泡排序？例如，使用 VARIANT、变量过多等会显着降低性能。我知道冒泡排序并不是特别快，但我没想到它会这么慢。

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

算法输入：2D 数组和一或两列排序依据，每个 asc 或 desc。我不一定需要闪电般快速，但 5,000 行 30 秒是完全不可接受的

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.

编辑：我决定改用 QuickSort。如果有兴趣，请参阅下面的帖子以获取代码。

回答by Peter Albert

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

首先：不要在 5000 行上使用冒泡排序！这将需要 5000^2/2 次迭代，即 12.5B 次迭代！最好使用像样的 QuickSort 算法。在这篇文章的底部，您会找到一个可以用作起点的文章。它只比较第 1 列。在我的系统上，排序耗时 0.01 秒（而不是冒泡排序优化后的 4 秒）。

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.

现在，对于挑战，请查看以下代码。它以原始运行时间的 30% 左右运行 - 同时显着减少了代码行数。

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.

• 对主数组使用 Double 而不是 Variant（Variant 在内存管理方面总是会带来一些开销）
• 减少变量的调用/切换次数 - 我没有使用您的子类 CompareOne 和 CompareTwo，而是内联了代码并对其进行了优化。另外，我直接访问了这些值，而没有将它们分配给临时变量
• 仅填充数组就占用了总时间的 10%。相反，我批量分配了数组（必须为此切换行和列），然后将其转换为双数组
• 速度可以通过两个独立的循环进一步优化——一个用于一列，一个用于两列。这将运行时间减少了约 10%，但会使代码膨胀，因此将其排除在外。

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:

这是一个 QuickSort 实现：

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

回答by TheBigC

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.

这是我为任何感兴趣的人实施的快速排序。我确信代码可以清理得很干净，但这是一个好的开始。此代码在不到一秒的时间内对 10,000 行进行了排序。

 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

回答by angelatlarge

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.

• 您真的不想对具有超过 20-30 个项目（最多）的任何项目使用 N^2 算法。如果你有 5000-10000 行，从 BubbleSort 开始是一个错误，恕我直言
• VBA 是不可预测的。除了放弃bubbleSort（问问Barack Obama），您还想尝试在VBA 中做事的不同方式。

For example:

例如：

• Replace for ... nextloops with for ... eachloops: 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.

• 用for ... next循环替换循环for ... each：后者（矛盾的是）可以更快
• 尝试使用变体而不是立即转换为原始类型并使用它们。过去，VBA 处理变体的速度要快得多，但 YMMV。