VBA Application.Runの代わりにCallByNameを利用したCollectionのバブルソート

以前、Collectionのバブルソートを記事にした。
thom.hateblo.jp

この記事ではCollectionに数値や文字列ではなくオブジェクトが入っていた場合も任意のプロパティを元に比較を行うことができる。プロパティの指定には別途以下のようなFunctionプロシージャを用意し、ソートのコードにそのプロシージャ名を文字列で渡すことでソートに利用するキーを渡すという仕組み。

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

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

ソートするコードではApplication.Runメソッドでこれらのソートキーを呼び出し、オブジェクト同士の比較する際のプロパティに使用する。

さて、この記事は公開からすでに1年前が経過したが、最近kantokuさんがその記事を取り上げてくれたようだ。
kantoku.hatenablog.com

上記の記事はCATIAという3次元CADソフトでVBAマクロを扱ったものであるが、CATIAにはApplication.Runメソッドが存在せずお悩みの様子。

Application.RunはExcelが持つメソッドである。ほかにWordやPowerPointにもRunメソッドが存在するが、それはあくまで各アプリケーションに実装されているだけで、VBAの標準機能ではない。

そこで今回はApplication.Runの代わりにVBA標準のCallByName関数を使って汎用性のあるCollectionのソートを書いてみようと思う。

CallByNameはどうやら標準モジュール上のコードを呼ぶことはできないようなので、ソートキーはクラスモジュール上に実装することにした。

作り方

まずクラスモジュールを挿入し「SortKeys」という名称に変更する。
それから以下のコードを記述する。

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

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

次に標準モジュールを挿入し、まずはApplicatoin.Runの代わりとなるコードを挿入する。
ここではCallByName関数を利用しており、新規のSortKeysオブジェクトとそのメソッド名を利用してプロシージャ呼び出しを行っている。

Function GetSortKeyByName(procName As String, V As Variant) As Variant
    GetSortKeyByName = CallByName(New SortKeys, procName, VbMethod, V)
End Function

毎回SortKeysオブジェクトを作成しなおすのでかなりムダが多いけど、実用上は(今のところ)何の問題もない。

次にCollectionの要素を入れ替えるCollectionSwapプロシージャを追加。

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

これは冒頭で紹介した記事からそのまま持ってきた。

次に実際にバブルソートを行うコード。

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 GetSortKeyByName(SortKeyFunction, C(i)) _
                > GetSortKeyByName(SortKeyFunction, C(j)) Then
                    CollectionSwap C, i, j
            End If
        Next j
    Next i
End Sub

これもほぼ冒頭で紹介した記事から持ってきたものであるが、Application.Runの代わりに先ほど挿入したGetSortKeyByNameプロシージャを呼び出している。

これで準備完了。あとは使うだけ。

Excelの場合は以下のコードを挿入し、適当にシートにシェイプを配置してから実行すると、シェイプのTopプロパティの昇順にイミディエイトウインドウに出力される。

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

もっとシンプルに改良する

CallByName関数を利用すると、そもそもSortKeyを別の関数に持たせなくても直接オブジェクトのプロパティ名を文字列で呼び出すことができる。わざわざクラスモジュールを作る必要もない。
プロパティを備えたオブジェクトをソートする場合にはそちらのほうがシンプルで便利だ。

まず、CollectionSwapプロシージャはこれまで通り。

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

CSortは少し変更した。

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

SortKeyをOptionalで渡し、もし省略された場合は中身を直接比較、SortKeyが文字列で渡された場合はそれをCallByNameで取り出して比較する。

IsMissingで判定をするためSortKeyはVariant型にしているが、これは文字列が渡される想定だ。

Optional SortKey As String = ""として、空文字判定でも良い。普段はそうするんだけれど、たまにはIsMissingも使ってあげようかなと。

さて、準備に必要なコードは上記の2点のみ。
GetSortKeyByNameも要らないし、SortKey1、SortKey2も要らなくなる。

上記のコードを使ったサンプルがこちら

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, "Top"
    CSort C2
    
    'ソート結果出力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