1

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

算法输入：二维数组和一或两列排序依据，每个 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

非常感谢您的任何帮助或建议！

编辑：我决定改用快速排序。如果有兴趣，请参阅下面的代码以获取代码。

4

3 回答 3

6

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

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

主要杠杆是：

  • 对主数组使用 Double 而不是 Variant（Variant 在内存管理方面总是有一些开销）
  • 减少变量的调用/切换次数 - 我没有使用您的 subs 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

这是一个快速排序的实现：

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
于 2013-03-19T20:58:39.293 回答
1

我的想法：

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

例如：

  • for ... next用循环替换for ... each循环：后者（自相矛盾）可以更快
  • 尝试使用变体而不是立即转换为原始类型并使用它们。过去，VBA 处理变体的速度要快得多，但是 YMMV。
于 2013-03-19T20:10:07.597 回答
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
于 2013-03-20T23:06:35.363 回答