應用程式/氣泡排序在一個鍵上的 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