VBAでクイックソート その２

copy

Private Sub QuickSortB()
    Dim SortArray           As Variant
    Dim EndRow              As Long

    With ActiveSheet
        EndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        SortArray = .Range(.Cells(1, 1), .Cells(EndRow, 1)).Value
    End With

    Call QuickB(SortArray, LBound(SortArray, 1), UBound(SortArray, 1))

    With ActiveSheet
        .Range(.Cells(LBound(SortArray, 1), 3),
               .Cells(UBound(SortArray, 1), 3)) = SortArray
    End With

End Sub 

copy

Private Sub QuickB(ByRef SortArray As Variant, _
                   ByVal topPosi As Long, _
                   ByVal tailPosi As Long)
    Dim PivotPosi           As Long

    If tailPosi - topPosi <= 0 Then
        '再帰の終了条件です。
    Else
        PivotPosi = Pivot_Posi(SortArray, topPosi, tailPosi)
        Call QuickB(SortArray, topPosi, PivotPosi - 1)
        Call QuickB(SortArray, PivotPosi + 1, tailPosi)
    End If

End Sub 

copy

Private Function Pivot_Posi(ByRef SortArray As Variant, _
                            ByVal topPosi As Long, _
                            ByVal tailPosi As Long)
    Dim Pivot               As String
    Dim smallPosi           As Long
    Dim largePosi           As Long
    Dim BUF                 As String

    '軸を配列の中央の値にします。（下図　置き換え0）
    Pivot = SortArray(Int((topPosi + tailPosi) / 2), 1)
    'topPosiのインデックスにある値と入れ替えます。
    SortArray(Int((topPosi + tailPosi) / 2), 1) = SortArray(topPosi, 1)
    SortArray(topPosi, 1) = Pivot

    'topPosi は Pivot のインデックスなので、探査は topPosi +1 となります。
    smallPosi = topPosi + 1
    largePosi = tailPosi

    '無限ループを開始します。
    Do While True

        'この例だと、上に Pivot より小さい値の領域、下に超える値の領域とします。
        '上から下へ探査して Pivot より大きい値のインデックスを探します。
        'このループは Pivot より小さい値の場合進み、超える場合は進みません。
        'したがって、大きい値のインデックスで止まります。
        '= を忘れずに必ずつけます。忘れると無限ループになります。
        Do While SortArray(smallPosi, 1) <= Pivot And smallPosi < tailPosi
            smallPosi = smallPosi + 1
        Loop

        '逆に、下から上へ探査して Pivot より小さい値のインデックスを探します。
        'このループは Pivot を超える値の場合進み、超えない場合は進みません。
        'したがって、 Pivot 以下の値のインデックスで止まります。
        Do While SortArray(largePosi, 1) > Pivot And largePosi > topPosi
            largePosi = largePosi - 1
        Loop

        '入れ子のループが終わり交差（smallPosiとlargePosi）しているか調べます。
        If smallPosi < largePosi Then
            '交差していなければ置き換えます。（下図　置き換え1）
            BUF = SortArray(smallPosi, 1)
            SortArray(smallPosi, 1) = SortArray(largePosi, 1)
            SortArray(largePosi, 1) = BUF
        Else
            'smallPosiとlargePosiは交差し領域の区分は終わったので、ループを抜けます。
            Exit Do
        End If

    Loop

    'smallPosiとlargePosiは交差して無限ループを抜けているので、
    'smallPosi は Pivot を超える値の最終位置、
    'また largePosi は Pivot 以下の値の最終位置となります。
    'したがって、Pivot のあるべきインデックスが求まったので、
    'largePosi の値と、topPosi の値（Pivot）と置き換えます。（下図　置き換え2）
    SortArray(topPosi, 1) = SortArray(largePosi, 1)
    SortArray(largePosi, 1) = Pivot

    Pivot_Posi = largePosi
    
End Function