我很惊讶这个冒泡排序算法使用VBA的速度有多慢。所以我的问题是我做错了什么/效率低下，或者这只是最好的VBA和冒泡排序吗？例如，可能使用VARIANT，太多变量等会大大降低性能。我知道冒泡排序并不是特别快，但我认为这不会那么慢。
算法输入：2D数组和一列或两列进行排序，每个asc或desc。 我不一定需要快速闪电，但5000行的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
非常感谢您的帮助或建议!!
编辑：我决定改用QuickSort。如果感兴趣，请参阅下面的帖子。
答案 0 :(得分：5)
首先：不要在5000行上使用冒泡排序！它需要5000 ^ 2/2迭代，即12.5B迭代！更好地使用体面的QuickSort算法。在这篇文章的底部你会找到一个你可以用作起点的文章。它只比较第1列。在我的系统上，排序花费0.01s（而不是优化冒泡排序后的4s）。
现在，对于挑战，请查看以下代码。它运行时间约为原始运行时间的30％ - 同时显着减少了代码行。
主要的杠杆是：
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
答案 1 :(得分：1)
我的想法：
例如：
for ... next循环替换for ... each循环：后者（矛盾地）可以更快答案 2 :(得分：1)
这是我对任何感兴趣的人的快速排序的实现。我确信代码可以清理一下但是，但这是一个好的开始。此代码在不到一秒的时间内对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