前回は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
すると、こんな感じでカラフルな四角形が沢山できる。
今回はこれを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にそれぞれデータが降ろされる。
コードの書き換え
途中経過を残してないのであまり語れないけれど、コードの改造は以下の順に行った。
- 変数宣言の位置などを自分好みに書き換え
- Stackクラスを使ってコードを書き換え
- Collectionを使ったコードに書き換え
- オブジェクトのTopプロパティ固定のソートに書き換え
- 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
頭が追いつかないので今のところ具体的に作る予定はないが。