VBAでクイックソート

2022年5月29日

VBAでクイックソートコードを作成

VBAには、配列の演算子がありません。Python、Rなど配列の演算がとても楽にきれいなコードでできますが、VBAにはないので自分でゴリゴリとやります。
ソートしたい配列の中央値を基準として、小さい値、大きい値を新たに２つ配列をつくりそれぞれ振り分けてセットしていきます。振り分けて作った配列を再帰して同じことを繰り返します。

エクセルのA列に、ソートしたいデータを作りC列にソートした結果を表示しています。10,000件あまりをソートしてみましたところ、一瞬にできました。

530,0000件、600,000件で試してみました。スッタク領域不足のエラーになりました。520,000件は35秒で無事ソートできました。

520,000<２の17乗＝524,288＜530,000
17層の再帰までは良さそうです。

EXCELのVBAコード

copy

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim BUF                 As Variant
    Dim PickUP()            As String
    Dim RES                 As Variant
    Dim PasteArray()        As String
    Dim I                   As Long
    Dim EndRow              As Long

    With ActiveSheet
        EndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        BUF = .Range(.Cells(1, 1), .Cells(EndRow, 1)).Value
    End With
    ReDim PickUP(UBound(BUF, 1))

    For I = 1 To UBound(PickUP)
        PickUP(I) = BUF(I, 1)
    Next I
    PickUP(0) = UBound(PickUP)

    RES = Quick(PickUP)

    ReDim PasteArray(1 To UBound(RES), 1 To 1)
    For I = 1 To UBound(RES)
        PasteArray(I, 1) = RES(I)
    Next I

    Range(Cells(1, 3), Cells(UBound(PasteArray, 1), 3)) = PasteArray

End Sub

ソートの再帰コードです。

copy

Private Function Quick(ByRef Target As Variant) As Variant
    Dim Pivot               As String
    Dim Leftlist()          As String
    Dim LCount              As Long
    Dim RightList()         As String
    Dim RCount              As Long
    Dim RBuf                As Variant
    Dim lBuf                As Variant
    Dim RES()               As String
    Dim I                   As Long
    Dim Posi                As Long

    If Target(0) < 2 Then
        '再帰の終了条件です。
        '再帰させずそのまま返します。
        Quick = Target
    Else

        '軸を中央にします。
        Posi = Target(0) / 2
        '比較する基準値
        Pivot = Target(Posi)
        '基準値より小さい値（<）を格納する配列
        ReDim Leftlist(Target(0))
        '基準値より大きい値(>=)を格納する配列
        ReDim RightList(Target(0))
        '格納するインデックス
        LCount = 0
        RCount = 0

        For I = 1 To Target(0)
            If I <> Posi Then
                If Pivot < Target(I) Then
                    RCount = RCount + 1
                    RightList(RCount) = Target(I)
                Else
                    LCount = LCount + 1
                    Leftlist(LCount) = Target(I)
                End If
            End If
        Next I

        '配列のトップに値の数をセットします。
        RightList(0) = RCount
        Leftlist(0) = LCount
        '余分なインデックスを削除します。
        ReDim Preserve RightList(RCount)
        ReDim Preserve Leftlist(LCount)

        '作られた配列を再帰します。
        RBuf = Quick(RightList)
        lBuf = Quick(Leftlist)

        '返された配列を結合して返します。
        ReDim RES(LCount + 1 + RCount)
        For I = 1 To LCount
            RES(I) = lBuf(I)
        Next I
        RES(LCount + 1) = Pivot
        For I = 1 To RCount
            RES(LCount + 1 + I) = RBuf(I)
        Next I

        Quick = RES

    End If
    
End Function