应用程序/冒泡排序在一个键上的 Visual Basic

概要

此页面适用于对二维数据进行排序的过程。此外，由于某些过程使用多重排序方法，因此本页面仅限于对单个键进行排序。也就是说，使用一列或一行作为排序的基础。

在 VBA 中冒泡排序数组

• 此过程用于对二维数组进行排序。这可能是最常见的需求。这些选项允许对列或行进行排序，选择排序索引，以及选择升序或降序排序。同样，可以选择将排序后的工作结果返回到另一个数组中，同时保持输入数组不变，或者如果没有提供新数组，则将排序后的结果返回到原始数组中。
• 冒泡排序的速度适用于大多数 VBA 项目，虽然更快的排序算法被用于要求更高的应用程序。虽然在 Excel 中不可用，但使用 MS Word 的用户可以考虑调用 WordBasic 的 SortArray 函数。在 Excel 中，WorksheetFunctions 可能需要研究一下它们在排序方面的用途。

代码模块

Function SortArr2D1Key(ByRef vA As Variant, _
                       Optional ByVal bIsAscending As Boolean = True, _
                       Optional ByVal bIsRowSort As Boolean = True, _
                       Optional ByVal SortIndex As Long = -1, _
                       Optional ByRef vRet As Variant) As Boolean
'--------------------------------------------------------------------------------
' Procedure : SortArr2D1Key
' Purpose   : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
'             Options include in-place, with the source changed, or
'             returned in vRet, with the source array intact.
'             Optional parameters default to: ROW SORT in place, ASCENDING,
'             using COLUMN ONE as the key.
'--------------------------------------------------------------------------------
    
    Dim condition1 As Boolean, vR As Variant
    Dim i As Long, j As Long, y As Long, t As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find bounds of vA data input array
    loR = LBound(vA, 1): hiR = UBound(vA, 1)
    loC = LBound(vA, 2): hiC = UBound(vA, 2)
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vRet)
    'If Not bWasMissing Then Set vRet = Nothing
    
    'check input range of SortIndex
    If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
        MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
        Exit Function
    Else:
    End If
    
    'pass to a work variable
    vR = vA
    
    'steer input options
    If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
    
ROWSORT:
    For i = loR To hiR - 1
        For j = loR To hiR - 1
            If bIsAscending Then
                condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
            Else
                condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
            End If
            If condition1 Then
                For y = loC To hiC
                    t = vR(j, y)
                    vR(j, y) = vR(j + 1, y)
                    vR(j + 1, y) = t
                Next y
            End If
        Next
    Next
    GoTo TRANSFERS
    
COLSORT:
    For i = loC To hiC - 1
        For j = loC To hiC - 1
            If bIsAscending Then
                condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
            Else
                condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
            End If
            If condition1 Then
                For y = loR To hiR
                    t = vR(y, j)
                    vR(y, j) = vR(y, j + 1)
                    vR(y, j + 1) = t
                Next y
            End If
        Next
    Next
    GoTo TRANSFERS
    
TRANSFERS:
    'decide whether to return in vA or vRet
    If Not bWasMissing Then
        'vRet was the intended return array
        'so return vRet leaving vA intact
        vRet = vR
    Else:
        'vRet is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'set return function value
    SortArr2D1Key = True
    
End Function