VBA Collectionのバブルソート～単純実装からリフレクションを使った汎用化まで

VBAでソートプログラムを探すと割と簡単に見つかるが、ほとんどが配列をソートするものだ。
今回私が仕事で使うとあるマクロの作成中、コレクションのソートが必要になったので方法を紹介しようと思う。

必要な命令を自作する

まず、どのようなソートであれ必要になるのが、値の交換を行う手段である。

配列で1番目のデータと2番目のデータを交換するには、データ退避用の変数を用意して次のように交換する。

Tmp = Arr(1)
Arr(1) = Arr(2)
Arr(2) = Tmp

コレクションの場合はやや面倒で、値を直接書き換えることができない。
そこで、追加・削除を使って実装する。

バブルソートの中でやるとコードが複雑になるので、CollectionSwapというプロシージャにまとめた。

Sub CollectionSwap(C As Collection, Index1 As Long, Index2 As Long)
    Dim Item1 As Variant, Item2 As Variant
    Item1 = C.Item(Index1)
    Item2 = C.Item(Index2)
    
    C.Add Item1, After:=Index2
    C.Remove Index2
    C.Add Item2, After:=Index1
    C.Remove Index1
End Sub

プログラムを作成するときは、このように部品に切り分けて考えると楽である。作成中に面倒くさいと思うことが出てきたら、「どんな命令があると楽か」という風に考えよう。私が考えた順はこうだ。

コレクションをバブルソートするプログラムを作ろう。
しかしコレクションでは値の交換が面倒くさい。
簡単に値を交換できる命令があったら楽なのに。
そうだ、Swap命令を作ろう。

さて、このCollectionSwap命令には1つ欠陥がある。

以下の部分であるが、VBAではオブジェクトの代入にはSet句が必要である。

    Item1 = C.Item(Index1)
    Item2 = C.Item(Index2)

つまり、コレクションのアイテムがオブジェクトだった場合、このコードはエラーになる。かといって単純にSetを付けると、今度はオブジェクトではなかった場合にエラーになる。

そこで、オブジェクトかどうかを判定して代入文を変えるように変更した。

Sub CollectionSwap(C As Collection, Index1 As Long, Index2 As Long)
    Dim Item1 As Variant, Item2 As Variant
    
    If IsObject(C.Item(Index1)) Then
        Set Item1 = C.Item(Index1)
    Else
        Let Item1 = C.Item(Index1)
    End If
    
    If IsObject(C.Item(Index2)) Then
        Set Item2 = C.Item(Index2)
    Else
        Let Item2 = C.Item(Index2)
    End If
    
    C.Add Item1, After:=Index2
    C.Remove Index2
    C.Add Item2, After:=Index1
    C.Remove Index1
End Sub

Letは省略しても良いのだが、Setとの対比を考慮するとこのケースではあったほうがコードが締まるので今回はあえて付けた。

バブルソートの実装

そして、これを使って作成したバブルソートがこちら。

Sub CollectionBubbleSort()
    'ソート用データの準備
    Dim C As New Collection
    C.Add "E"
    C.Add "A"
    C.Add "C"
    C.Add "D"
    C.Add "B"
    C.Add "F"

    'バブルソート
    Dim i As Long, j As Long
    For i = 1 To C.Count
        For j = C.Count To i Step -1
            If C(i) > C(j) Then
                CollectionSwap C, i, j
            End If
        Next j
    Next i
    
    'ソート結果出力
    Dim k As Long
    For k = 1 To C.Count
        Debug.Print (C(k))
    Next
End Sub

今回はサンプルなので、データの準備とソートと出力を1つのプロシージャに書いたが、ソートはソートでまた別のプロシージャに分離しても良い。

ただ、汎用性を得にくいのがバブルソートの中の次の文。

If C(i) > C(j) Then

上のサンプルではコレクションの中身がString型なのでうまくいくが、オブジェクト型だった場合は、どのプロパティで比較するのかを明示しないといけない。

例えば、シート上のオートシェイプを格納し、そのY座標をもとにソートするなら比較の対象はTopプロパティとなる。

If C(i).Top > C(j).Top Then

ソートプログラムの汎用化

前述のコードでは、アイテムのプロパティをハードコーディングしないといけないため、ソートプロシージャを分離するメリットが薄くなる。

そこで、メンテナンスの影響を局所的にする方法として、ソートのキーとなるプロパティを取り出すSortKey関数を別に用意した。

Function SortKey(V As Variant)
    SortKey = V.Top
End Function

バブルソートは、CSortプロシージャとして分離させる。

Sub CSort(C As Collection)
    Dim i As Long, j As Long
    For i = 1 To C.Count
        For j = C.Count To i Step -1
            If SortKey(C(i)) > SortKey(C(j)) Then
                CollectionSwap C, i, j
            End If
        Next j
    Next i
End Sub

こうしておくと、ソート自体は汎用的な関数として独立させることができ、Itemの中身が変わってもメンテナンスはSortKey関数の変更だけになる。

たとえば従来どおりString型の比較を行うなら、以下のように引数をそのまま返せば良いし、

Function SortKey(V As Variant)
    SortKey = V
End Function

X方向の順番を取り出すならLeftプロパティをセットすれば良い。

Function SortKey(V As Variant)
    SortKey = V.Left
End Function

さて、分離したCSortを使ってシート上のオートシェイプの名前を上から順にDebug.Printするコードを書いてみた。
SortKeyの返すプロパティはTopに設定してある。

Sub CollectionSortSample()
    'ソート用データの準備
    Dim C As New Collection
    For Each s In ActiveSheet.Shapes
        C.Add s
    Next

    'ソート呼び出し
    CSort C
    
    'ソート結果出力
    Dim k As Long
    For k = 1 To C.Count
        Debug.Print (C(k).Name)
    Next
End Sub

さらなる汎用化を求めて

これまでのコードでもある程度の汎用化は達成しているが、コレクションのソートを同じプログラムで複数の用途に使いまわすことができない。
例えばStringをソートしたい場合とオートシェイプをソートしたい場合ではSortKeyの書き換えが必要であるが、場合によって複数のソートキーを使い分けることができないからである。

そこでCSortプロシージャで呼び出していたSortKey関数を、関数名の文字列で呼び出せるように変更した。

Sub CSort(C As Collection, SortKeyFunction As String)
    Dim i As Long, j As Long
    For i = 1 To C.Count
        For j = C.Count To i Step -1
            If Application.Run(SortKeyFunction, C(i)) _
                > Application.Run(SortKeyFunction, C(j)) Then
                    CollectionSwap C, i, j
            End If
        Next j
    Next i
End Sub

ApplicationのRunメソッドは、与えられたプロシージャ名のプロシージャを呼び出すことができ、その戻り値も有効である。
例えばSortKey1とSortKey2を作成すれば、呼び出し時にCSort C, "SortKey1"という風にソートキー関数を名前で呼び分けることができる。

Function SortKey1(V As Shape) As Double
    SortKey1 = V.Top
End Function

Function SortKey2(V As String) As String
    SortKey2 = V
End Function

これを利用したコレクションのソートサンプルがこちら

Sub CollectionSortSample()
    'ソート用データ1の準備
    Dim C1 As New Collection
    For Each s In ActiveSheet.Shapes
        C1.Add s
    Next
    
    'ソート用データ2の準備
    Dim C2 As New Collection
    C2.Add "E"
    C2.Add "A"
    C2.Add "C"
    C2.Add "D"
    C2.Add "B"
    C2.Add "F"

    'ソート呼び出し
    CSort C1, "SortKey1"
    CSort C2, "SortKey2"
    
    'ソート結果出力1
    Dim k As Long
    For k = 1 To C1.Count
        Debug.Print (C1(k).Name)
    Next
    
    'ソート結果出力2
    Dim l As Long
    For l = 1 To C2.Count
        Debug.Print (C2(l))
    Next
End Sub

コレクションC1は画像を、C2にはテキストを格納し、それぞれ別のソートキーを使って呼び出しを行っている。

このように、プログラム中の要素を文字列で指定するテクニックを「リフレクション」という。
VBAにはプロシージャ呼び出しくらいしか備わっていないので、.Netプログラマの方にVBAでリフレクションなどと言うと笑われるかもしれない。
しかし概念として覚えておくことは重要で、概念を覚えて使いこなすには、名前にマッピングしておくのが一番なので、あえてリフレクションという用語を紹介した。