VBA气泡排序算法慢

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

现在，面对挑战，请查看下面的代码。它以原始运行时间的〜30％运行-同时显着减少了代码行。

主要杠杆是：

• 对主数组使用Double而不是Variant（在内存管理方面，Variant总是会产生一些开销）
• 减少变量的调用/切换次数-我内联代码并对其进行了优化，而不是使用您的subs CompareOne和CompareTwo。另外，我直接访问了这些值，而没有将它们分配给temp变量
• 仅填充阵列就花费了总时间的10％。相反，我批量分配了数组（不得不为此切换行和列），然后将其强制转换为双精度数组

• 通过具有两个单独的回路可以进一步优化速度-一个回路用于一列，一个回路用于两列。这样可以将运行时间减少约10％，但会使代码过大，因此省略了代码。

  Option Explicit

  Sub sortA()

  Dim start_time As DoubleDim varArray As Variant, dblArray() As DoubleDim a, b As LongConst rows As Long = 5000Const cols As Long = 3start_time = Timer'Copy everything to array of type variantvarArray = ArraySheet.Range("A1").Resize(rows, cols).Cells'Cast variant to doubleReDim dblArray(1 To rows, 1 To cols)For a = 1 To rows    For b = 1 To cols        dblArray(a, b) = varArray(a, b)    Next bNext aBubbleSort dblArray, 1, False, 2, TrueMsgBox 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 LongDim FirstCol As LongDim LastCol As LongDim lTemp As DoubleDim i, j, k As LongDim CompareResult As BooleanLastRow = 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 jNext i

  End Sub

这是一个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 IfEnd SubPrivate 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) = varTempEnd Sub