読者です 読者をやめる 読者になる 読者になる

t-hom’s diary

主にVBAネタを扱っているブログです。

CallByNameを使ったコレクションの非再帰クイック&挿入ハイブリッドソート

VBA

前回はCallByNameを使ってCollectionのバブルソートを作成した。
thom.hateblo.jp

そのあとコメントでやりとりがあり、非再帰のクイック&挿入ハイブリッドソートでお悩みの様子。
kantoku.hatenablog.com

幸いにもベースになるコードは以下にあるとのことで、
クイックソートと挿入ソートのハイブリッド | 愚者の経験

いろいろ弄ってたら何とか完成したので公開しようと思う。

ソートする対象を準備

コード本体に入る前に、ソートする対象を準備しよう。
まず以下のコードをSheet1モジュールに貼り付けて実行する。

Sub ランダムに四角形をちりばめる()
    Dim s As Shape
    For i = 1 To 50
        x = WorksheetFunction.RandBetween(0, 500)
        y = WorksheetFunction.RandBetween(0, 250)
        Set s = Sheets(1).Shapes.AddShape(msoShapeRectangle, x, y, 30, 30)
        Dim col(1 To 3)
        For h = 1 To 3
            col(h) = WorksheetFunction.RandBetween(0, 255)
        Next
        s.Fill.ForeColor.RGB = RGB(col(1), col(2), col(3))
        s.Line.ForeColor.RGB = RGB(255 - col(1), 255 - col(2), 255 - col(3))
    Next
End Sub

すると、こんな感じでカラフルな四角形が沢山できる。
f:id:t-hom:20170102095900p:plain

今回はこれをCollectionに追加し、Leftプロパティの昇順、Topプロパティの昇順でそれぞれシェイプの名前をDebug.Printしてみようと思う。

スタッククラスの作成

今回、非再帰クイックソートを作るのだが、これにはスタックが必要になる。
再帰ではプロシージャのコールスタックに自動でローカル変数がスタックされるところ、非再帰で作るとなると自分でスタックを実装しないといけない。

参考にしたサイトではDictionaryオブジェクトを使ってスタックの動作を再現していた。しかしメインコード内で自分でスタックポインタを管理すると非常にややこしくなるので、クラスを使って自分でスタックを実装してしまおう。

実はむかーし作ったことがあるのだが、
thom.hateblo.jp

今回の案件に合わせてLeftIndexとRightIndexを一度に管理できるように改造したのがこちら。

Private C As Collection

Private Sub Class_Initialize()
    Set C = New Collection
End Sub

Sub Push(ByVal L, ByVal R)
    C.Add Array(L, R)
End Sub

Function Count() As Long
    Count = C.Count
End Function

Sub Pop(ByRef L, ByRef R)
    L = C.Item(C.Count)(0)
    R = C.Item(C.Count)(1)
    C.Remove C.Count
End Sub

クラスモジュールをStackという名前で作成し、上記コードを張り付ける。
これで、Push LeftIndex, RightIndexとすればスタックにデータが積まれ、Pop LeftIndex, RightIndexとすれば変数LeftIndex, RightIndexにそれぞれデータが降ろされる。

コードの書き換え

途中経過を残してないのであまり語れないけれど、コードの改造は以下の順に行った。

  1. 変数宣言の位置などを自分好みに書き換え
  2. Stackクラスを使ってコードを書き換え
  3. Collectionを使ったコードに書き換え
  4. オブジェクトのTopプロパティ固定のソートに書き換え
  5. CallByNameによるプロパティ可変コードに書き換え

配列をコレクションに書き換える際は、下限が1になるので2~3箇所0を1に書き換える必要がある。これは適当に実行しながらエラーが出る度に直していった。あまり良いやり方ではないが、頭が追いつかないので力技だ。

完成したコード

以下のMainを実行すると、propNameに指定されたプロパティの昇順に並びかわる。
※実行には以下に加え、先ほど紹介したStackクラスが必要。

Sub Main()
    Const propName = "Left"
    Dim C As Collection
    Set C = New Collection
    For Each s In Sheets(1).Shapes
        C.Add s
    Next
    QuickSort C, propName
    
    For i = 1 To C.Count
        Debug.Print CallByName(C(i), propName, VbGet), C(i).Name
    Next
End Sub

Private Sub CollectionSwap(ByRef List As Collection, ByVal Idx1&, ByVal Idx2&)
    Dim Item1, Item2
    With List
        If IsObject(.Item(Idx1)) Then
            Set Item1 = .Item(Idx1)
            Set Item2 = .Item(Idx2)
        Else
            Let Item1 = .Item(Idx1)
            Let Item2 = .Item(Idx2)
        End If
        .Add Item1, After:=Idx2
        .Remove Idx2
        .Add Item2, After:=Idx1
        .Remove Idx1
    End With
End Sub

Public Sub QuickSort(C As Collection, propName As String)
    Dim LeftIdx As Long
    Dim RightIdx As Long
    Dim Pivot As Variant
    
    Dim i As Long
    Dim j As Long
    Dim Stack As Stack: Set Stack = New Stack
    
    Stack.Push 1, C.Count
    Do While Stack.Count > 0
        Stack.Pop LeftIdx, RightIdx

        If LeftIdx < RightIdx Then
        
            Set Pivot = C((LeftIdx + RightIdx) / 2)
            
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While CallByName(C(i), propName, VbGet) < CallByName(Pivot, propName, VbGet)
                    i = i + 1
                Loop
                Do While CallByName(C(j), propName, VbGet) > CallByName(Pivot, propName, VbGet)
                    j = j - 1
                Loop

                If i <= j Then
                    CollectionSwap C, i, j
                    i = i + 1: j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 1 Then
                If RightIdx - i <= 10 Then
                    ComboInsertionSort C, i, RightIdx, propName
                Else
                    Stack.Push i, RightIdx
                End If
            End If
            
            If j - LeftIdx >= 1 Then
                If j - LeftIdx <= 10 Then
                    ComboInsertionSort C, LeftIdx, j, propName
                Else
                    Stack.Push LeftIdx, j
                End If
            End If
        End If
    Loop
End Sub

Public Sub ComboInsertionSort(C As Collection, MinIdx As Long, MaxIdx As Long, propName As String)
    Dim i As Long, j As Long
    j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
            If CallByName(C(i + 1), propName, VbGet) < CallByName(C(i), propName, VbGet) Then
                CollectionSwap C, i, i + 1
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

これで、MainプロシージャのpropName定数を任意のプロパティ名に書き換えると、そのプロパティの順に出力されるようになる。

終わりに

人のコードを改造するのもまた楽しい作業である。
今回クイックソートでやったけれど、個人的にはマージソートでやってみたいなと思う。マージソートは安定ソートなので、例えばLeftプロパティで並び替えてからTopプロパティで並び替えると、Topが同じ値のオブジェクトではLeftの昇順が維持される。

↓過去に書いたマージソートの記事
thom.hateblo.jp
thom.hateblo.jp

頭が追いつかないので今のところ具体的に作る予定はないが。

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。