t-hom’s diary

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

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

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

  1. コレクションをバブルソートするプログラムを作ろう。
  2. しかしコレクションでは値の交換が面倒くさい。
  3. 簡単に値を交換できる命令があったら楽なのに。
  4. そうだ、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でリフレクションなどと言うと笑われるかもしれない。
しかし概念として覚えておくことは重要で、概念を覚えて使いこなすには、名前にマッピングしておくのが一番なので、あえてリフレクションという用語を紹介した。

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