我很惊讶于这个冒泡排序算法是如何缓慢使用VBA。所以我的问题是我做错了什么/低效的，还是这只是最好的VBA和冒泡排序会做什么？例如，可以使用变，变数太多，等大幅降低性能。我知道冒泡排序是不是特别快，但我没想到会是这样慢。

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.

算法输入：二维数组和一个或两个列进行排序，每递增或递减。 我不一定需要快如闪电，但30秒5,000行是完全不能接受的。

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!!

编辑：我决定用快速排序代替。看帖子下方为code如果有兴趣。

I decided to used QuickSort instead. See post below for the code if interested.

推荐答案

首先：不要在5000行使用冒泡排序！这将需要5000 ^ 2月2日反复，即12.5B迭代！最好使用一个体面的快速排序算法。在这篇文章的底部，你会发现一个你可以为一个起始点。它只比较1列。​​在我的系统中，排序了0.01秒（而不是4S冒泡排序的优化后）。

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

现在，接受挑战，看看下面code。它运行在〜原来运行时间的30％ - 和同时降低了线code显著

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.

主要杠杆是：

使用双，而不是变体的主阵列（变异总是带有一些开销在内存管理方面） 在减少变量来电/切换的数量 - 而不是用你的潜艇CompareOne和CompareTwo，我的内联code和优化它。另外，我直接访问该值，而不将其分配到一个临时变量 只需填充阵列用了10％的总时间。相反，我整批转让的数组（必须切换行和放大器;列了），然后浇铸到一个双阵列 一为一列，一个用于两列 - 在速度可以进一步通过具有两个独立的回路进行了优化。这减少了运行时间约10％，但涨大的code所以离开它了。 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