首先：不要在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 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

这是一个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