VBA If文の多重ネストを回避するチュートリアル

Chemiphysさんのブログで

If文のお化け

フィールド数が多いデータに取り組む④ - chemiphys’s blog

という名言を発見。

どうやら条件が増えすぎてIf文が多重ネストになってしまうということらしい。
ちょっと修正してみたので記事にして良いですかと確認を取ったところ快くOKしてくれたので紹介。

以下、オリジナルのマクロから該当のプロシージャだけ抜粋したもの。

Sub CSort(Col As Collection, Key1 As String, Key1昇順 As Boolean, Optional Key2 As String, Optional Key2昇順 As Boolean)
    Dim p1 As person, p2 As person
    Dim p1k1 As Variant, p2k1 As Variant, p1k2 As Variant, p2k2 As Variant
    'バブルソート
    Dim i As Long, j As Long
    For i = 1 To Col.Count
        For j = Col.Count To i Step -1
            Set p1 = Col(i)
            Set p2 = Col(j)
            
            If IsNumeric(Key1) Then
                p1k1 = CallByName(p1, "GetParameter", VbMethod, Key1)
                p2k1 = CallByName(p2, "GetParameter", VbMethod, Key1)
            Else
                p1k1 = CallByName(p1, Key1, VbGet)
                p2k1 = CallByName(p2, Key1, VbGet)
            End If
            
            If Key2 <> "" Then
                If IsNumeric(Key2) Then
                    p1k2 = CallByName(p1, "GetParameter", VbMethod, Key2)
                    p2k2 = CallByName(p2, "GetParameter", VbMethod, Key2)
                Else
                    p1k2 = CallByName(p1, Key2, VbGet)
                    p2k2 = CallByName(p2, Key2, VbGet)
                End If
            End If
            
            If Key1昇順 = True Then
                If Key2 <> "" Then
                    If p1k1 > p2k1 Then
                        CollectionSwap Col, i, j
                    ElseIf p1k1 = p2k1 Then
                        If Key2昇順 = True Then
                            If p1k2 > p2k2 Then CollectionSwap Col, i, j
                        Else
                            If p1k2 < p2k2 Then CollectionSwap Col, i, j
                        End If
                    End If
                Else
                    If p1k1 > p2k1 Then CollectionSwap Col, i, j
                End If
            Else
                If Key2 <> "" Then
                    If p1k1 < p2k1 Then
                        CollectionSwap Col, i, j
                    ElseIf p1k1 = p2k1 Then
                        If Key2昇順 = True Then
                            If p1k2 > p2k2 Then CollectionSwap Col, i, j
                        Else
                            If p1k2 < p2k2 Then CollectionSwap Col, i, j
                        End If
                    End If
                Else
                    If p1k1 > p2k1 Then CollectionSwap Col, i, j
                End If
            End If
        Next j
    Next i
End Sub

確かにIfのネストが深い。
特に「If Key1昇順 = True Then」以降が長いので、今回はここを修正していく方法をチュートリアル形式で解説しようと思う。

まずこの一番深いネストのIf文を、外部プロシージャに切り出してしまおう。
このように分割しても、必要な変数を全部引数で持ってこれば正常に動作する。

Sub 外部プロシージャ化(Key1昇順,Key2昇順, key2, p1k1, p2k1, p1k2, p2k2, Col, i, j)
    If Key1昇順 = True Then
        If key2 <> "" Then
            If p1k1 > p2k1 Then
                CollectionSwap Col, i, j
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then CollectionSwap Col, i, j
                Else
                    If p1k2 < p2k2 Then CollectionSwap Col, i, j
                End If
            End If
        Else
            If p1k1 > p2k1 Then CollectionSwap Col, i, j
        End If
    Else
        If key2 <> "" Then
            If p1k1 < p2k1 Then
                CollectionSwap Col, i, j
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then CollectionSwap Col, i, j
                Else
                    If p1k2 < p2k2 Then CollectionSwap Col, i, j
                End If
            End If
        Else
            If p1k1 > p2k1 Then CollectionSwap Col, i, j
        End If
    End If
End Sub

さて、次にこのプロシージャの役割は何だろうと考える。
このプロシージャのIf文はすべて、CollectionSwapを呼ぶか呼ばないかを決めるものである。
呼び出す際の引数もCol, i, jで固定。ということは最終的には呼ぶ・呼ばないの二択で良いのだ。
ということで、判定をフラグ化して呼び出し自体は最後にまとめてしまおう。

Sub 外部プロシージャ化(Key1昇順,Key2昇順, key2, p1k1, p2k1, p1k2, p2k2, Col, i, j)
    Dim flag As Boolean: flag = False
    If Key1昇順 = True Then
        If Key2 <> "" Then
            If p1k1 > p2k1 Then
                flag = True
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = True
                Else
                    If p1k2 < p2k2 Then flag = True
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = True
        End If
    Else
        If Key2 <> "" Then
            If p1k1 < p2k1 Then
                flag = True
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = True
                Else
                    If p1k2 < p2k2 Then flag = True
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = True
        End If
    End If
    If flag Then CollectionSwap Col, i, j
End Sub

いやまてよ。。ここでもし2回CollectionSwapが呼ばれるようなケースが存在する場合、これではまずい。
CollectionSwapは2回呼び出すと元通りになってしまうが、flag = Trueは何回呼んでもTrueである。つまり厳密に状態を再現できていない。

ということで、2回呼び出すと元に戻るように変更する。
flag = Not flagとしておけば、呼び出すたびに反転する。

Sub 外部プロシージャ化(Key1昇順,Key2昇順, key2, p1k1, p2k1, p1k2, p2k2, Col, i, j)
    Dim flag As Boolean: flag = False
    If Key1昇順 = True Then
        If Key2 <> "" Then
            If p1k1 > p2k1 Then
                flag = Not flag
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = Not flag
                Else
                    If p1k2 < p2k2 Then flag = Not flag
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = Not flag
        End If
    Else
        If Key2 <> "" Then
            If p1k1 < p2k1 Then
                flag = Not flag
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = Not flag
                Else
                    If p1k2 < p2k2 Then flag = Not flag
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = Not flag
        End If
    End If
    If flag Then CollectionSwap Col, i, j
End Sub

次に、外部プロシージャ化したものを今度は関数化する。
Swap判定というマクロ名に変更し、SubからFunctionに変更する。
CollectionSwapの呼び出しは本体のコードに戻すので、引数のCol, i jは不要になる。

Function Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If Key1昇順 = True Then
        If key2 <> "" Then
            If p1k1 > p2k1 Then
                flag = Not flag
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = Not flag
                Else
                    If p1k2 < p2k2 Then flag = Not flag
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = Not flag
        End If
    Else
        If key2 <> "" Then
            If p1k1 < p2k1 Then
                flag = Not flag
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = Not flag
                Else
                    If p1k2 < p2k2 Then flag = Not flag
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = Not flag
        End If
    End If
    Swap判定 = flag
End Function

さて、いよいよIfのネストを解消していきたいが、その前にまだ準備がある。
Swap判定関数を丸ごとコピーし、オリジナルの方を「旧Swap判定」、新しい方を「新Swap判定」に変更する。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    '省略
    新Swap判定 = flag
End Function

Function 旧Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    '省略
    旧Swap判定 = flag
End Function

現時点で新と旧の中身は全く同じ。唯一マクロ名と戻り値の代入部分だけが異なる2つの関数ができた。

そして次にテストコードを書く。

Sub 新Swap判定と旧Swap判定が等価であることのテスト()
    Dim Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2
    For Each Key1昇順 In Array(True, False)
    For Each Key2昇順 In Array(True, False)
    For Each key2 In Array("aaa", "")
    For Each p1k1 In Array(1, 3, 5)
    For Each p2k1 In Array(1, 3, 5)
    For Each p1k2 In Array(1, 3, 5)
    For Each p2k2 In Array(1, 3, 5)
        '↓とまったらアウト
        Debug.Assert _
        新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) = _
        旧Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2)
    Next: Next: Next: Next: Next: Next: Next
    MsgBox "正常に終了"
End Sub

これは、どのような引数を与えても2つの関数が返す値が同じになることを検証するものである。
現時点では2つの関数は中身が同じだから、当然正常に終了する。

これから新Swap判定をいじっていくが、中身をどれだけ変更しても、このテストさえパスすれば、新Swap判定は旧Swap判定と等価であるといえる。

つまりロジックを壊さずに安全にコードをいじる方法として、テストコードを用意しておくのだ。
そのためにわざわざ外部関数化した。コードをできる限りテスト可能にしておく、つまり関数化しておくことが安全にメンテナンスを行うコツである。

テストに関しては以下の記事でも書いた。
thom.hateblo.jp

ではいよいよ改造をはじめる。
まずは早期リターンを実現するため、新Swap判定関数の終わり付近に仮でQuitというフラグを追加する。

    End If
Quit:
    新Swap判定 = flag
End Function

早期リターンについては以下記事参照。
thom.hateblo.jp

次に「If Key1昇順 = True Then」の内部を早期リターンに書き換える。
■Before

        If key2 <> "" Then
            If p1k1 > p2k1 Then
                flag = Not flag
            ElseIf p1k1 = p2k1 Then
                If Key2昇順 = True Then
                    If p1k2 > p2k2 Then flag = Not flag
                Else
                    If p1k2 < p2k2 Then flag = Not flag
                End If
            End If
        Else
            If p1k1 > p2k1 Then flag = Not flag
        End If

■After

        If key2 = "" Then
            If p1k1 > p2k1 Then flag = Not flag
            GoTo Quit
        End If
        If p1k1 > p2k1 Then
            flag = Not flag
        ElseIf p1k1 = p2k1 Then
            If Key2昇順 = True Then
                If p1k2 > p2k2 Then flag = Not flag
            Else
                If p1k2 < p2k2 Then flag = Not flag
            End If
        End If

これでネストが1つ減った。ここでテストコードを実行し、正常終了するのを確認する。
「If Key1昇順 = True Then」に対応するElseの内部も、同様の変更を行う。

中央付近「ElseIf p1k1 = p2k1 Then」の部分も、分離して単純なIf文に変更する。

新Swap判定は以下のようになった。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If Key1昇順 = True Then
        If key2 = "" Then
            If p1k1 > p2k1 Then flag = Not flag
            GoTo Quit
        End If
        If p1k1 > p2k1 Then
            flag = Not flag
            GoTo Quit
        End If
        If p1k1 = p2k1 Then
            If Key2昇順 = True Then
                If p1k2 > p2k2 Then flag = Not flag
            Else
                If p1k2 < p2k2 Then flag = Not flag
            End If
        End If
    Else
        If key2 = "" Then
            If p1k1 > p2k1 Then flag = Not flag
            GoTo Quit
        End If
        If p1k1 < p2k1 Then
            flag = Not flag
            GoTo Quit
        End If
        If p1k1 = p2k1 Then
            If Key2昇順 = True Then
                If p1k2 > p2k2 Then flag = Not flag
            Else
                If p1k2 < p2k2 Then flag = Not flag
            End If
        End If
    End If
Quit:
    新Swap判定 = flag
End Function

ここでVBEのウインドウメニューから分割にチェックを入れ、片方のウインドウを「 If Key1昇順 = True Then」に、もう片方をそれに対応するElseにあわせる。

すると、先頭の項目が共通になっていることがわかる。

ではこれを外だししよう。
また、最後の条件も共通である。こちらも外だしする。

新Swap判定関数はこのようになった。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
        GoTo Quit
    End If
    If Key1昇順 = True Then
        If p1k1 > p2k1 Then
            flag = Not flag
            GoTo Quit
        End If
    Else
        If p1k1 < p2k1 Then
            flag = Not flag
            GoTo Quit
        End If
    End If
    If p1k1 = p2k1 Then
        If Key2昇順 = True Then
            If p1k2 > p2k2 Then flag = Not flag
        Else
            If p1k2 < p2k2 Then flag = Not flag
        End If
    End If
Quit:
    新Swap判定 = flag
End Function

あとなんとか纏めたいのは、ここと、

ここのわずかな違い。

関数型言語なら演算子を変数に入れてしまったりできるものがあるが、VBAではできないので、比較演算を外部関数化してしまおう。

Function IsGreater(which, A, B) As Boolean
    Select Case which
    Case 1: IsGreater = A > B
    Case 2: IsGreater = A < B
    End Select
End Function

これは、IsGreater(1, A, B)とすると、Aが大きい場合にTrue、IsGreater(2, A, B)とすると、Bが大きい場合にTrueを返す関数だ。

まずはこれを使って単に比較演算を置き換えてみる。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
        GoTo Quit
    End If
    If Key1昇順 = True Then
        If IsGreater(1, p1k1, p2k1) Then
            flag = Not flag
            GoTo Quit
        End If
    Else
        If IsGreater(2, p1k1, p2k1) Then
            flag = Not flag
            GoTo Quit
        End If
    End If
    If p1k1 = p2k1 Then
        If Key2昇順 = True Then
            If IsGreater(1, p1k2, p2k2) Then flag = Not flag
        Else
            If IsGreater(2, p1k2, p2k2) Then flag = Not flag
        End If
    End If
Quit:
    新Swap判定 = flag
End Function

すると、「大なり・小なり」の演算子の違いが、数字の1と2の違いに置き換わった。
ということは、Key1昇順、Key2昇順のフラグをIIf関数で数字の1と2に置き換えてしまえば。。

こうなる。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
        GoTo Quit
    End If
    Dim gtKey1: gtKey1 = IIf(Key1昇順, 1, 2)
    If Key1昇順 = True Then
        If IsGreater(gtKey1, p1k1, p2k1) Then
            flag = Not flag
            GoTo Quit
        End If
    Else
        If IsGreater(gtKey1, p1k1, p2k1) Then
            flag = Not flag
            GoTo Quit
        End If
    End If
    If p1k1 = p2k1 Then
        Dim gtKey2: gtKey2 = IIf(Key2昇順, 1, 2)
        If Key2昇順 = True Then
            If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
        Else
            If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
        End If
    End If
Quit:
    新Swap判定 = flag
End Function

そうすると先ほどなんとかしたいと言っていた部分が共通化されるので、まとめてしまえる。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
        GoTo Quit
    End If
    Dim gtKey1: gtKey1 = IIf(Key1昇順, 1, 2)
    If IsGreater(gtKey1, p1k1, p2k1) Then
        flag = Not flag
        GoTo Quit
    End If
    If p1k1 = p2k1 Then
        Dim gtKey2: gtKey2 = IIf(Key2昇順, 1, 2)
        If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
    End If
Quit:
    新Swap判定 = flag
End Function

十分短くなったのでGoto文を一つ消してElseに置き換え、

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
    Else
        Dim gtKey1: gtKey1 = IIf(Key1昇順, 1, 2)
        If IsGreater(gtKey1, p1k1, p2k1) Then
            flag = Not flag
            GoTo Quit
        End If
        If p1k1 = p2k1 Then
            Dim gtKey2: gtKey2 = IIf(Key2昇順, 1, 2)
            If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
        End If
    End If
Quit:
    新Swap判定 = flag
End Function

もう一つもElseIfに置き換えてしまえば、Quitフラグも不要になり、こうなる。

Function 新Swap判定(Key1昇順, Key2昇順, key2, p1k1, p2k1, p1k2, p2k2) As Boolean
    Dim flag As Boolean: flag = False
    If key2 = "" Then
        If p1k1 > p2k1 Then flag = Not flag
    Else
        Dim gtKey1: gtKey1 = IIf(Key1昇順, 1, 2)
        If IsGreater(gtKey1, p1k1, p2k1) Then
            flag = Not flag
        ElseIf p1k1 = p2k1 Then
            Dim gtKey2: gtKey2 = IIf(Key2昇順, 1, 2)
            If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
        End If
    End If
    新Swap判定 = flag
End Function

最後にテストコードを実行し、元のコードと等価であることを確認する。

そのまま関数としてメインコードから呼ぶ形でもよいし、メインのコードに書き戻すと、こうなる。

Sub CSort(Col As Collection, Key1 As String, Key1昇順 As Boolean, Optional key2 As String, Optional Key2昇順 As Boolean)
    Dim p1 As Person, p2 As Person
    Dim p1k1 As Variant, p2k1 As Variant, p1k2 As Variant, p2k2 As Variant
    'バブルソート
    Dim i As Long, j As Long
    For i = 1 To Col.Count
        For j = Col.Count To i Step -1
            Set p1 = Col(i)
            Set p2 = Col(j)
            
            If IsNumeric(Key1) Then
                p1k1 = CallByName(p1, "GetParameter", VbMethod, Key1)
                p2k1 = CallByName(p2, "GetParameter", VbMethod, Key1)
            Else
                p1k1 = CallByName(p1, Key1, VbGet)
                p2k1 = CallByName(p2, Key1, VbGet)
            End If
            
            If key2 <> "" Then
                If IsNumeric(key2) Then
                    p1k2 = CallByName(p1, "GetParameter", VbMethod, key2)
                    p2k2 = CallByName(p2, "GetParameter", VbMethod, key2)
                Else
                    p1k2 = CallByName(p1, key2, VbGet)
                    p2k2 = CallByName(p2, key2, VbGet)
                End If
            End If
            
            '↓新Swap判定のコードを書き戻した。
            Dim flag As Boolean: flag = False
            If key2 = "" Then
                If p1k1 > p2k1 Then flag = Not flag
            Else
                Dim gtKey1: gtKey1 = IIf(Key1昇順, 1, 2)
                If IsGreater(gtKey1, p1k1, p2k1) Then
                    flag = Not flag
                ElseIf p1k1 = p2k1 Then
                    Dim gtKey2: gtKey2 = IIf(Key2昇順, 1, 2)
                    If IsGreater(gtKey2, p1k2, p2k2) Then flag = Not flag
                End If
            End If
            If flag Then CollectionSwap Col, i, j
        Next j
    Next i
End Sub

Function IsGreater(which, A, B) As Boolean
    Select Case which
    Case 1: IsGreater = A > B
    Case 2: IsGreater = A < B
    End Select
End Function

見出しもつけずに書きなぐってしまったけど、以上。

VBA MsgBoxのオプションはなぜ足し算できるのか

VBAのメッセージボックスでは、以下のように適用したいスタイルを足し算できる。

Sub hoge()
    MsgBox "処理を続行しますか。", vbYesNo + vbQuestion + vbDefaultButton2, "確認"
End Sub

上記のマクロを実行すると、このように表示される。

変な文法だと思われた方もいるだろう。
MsgBoxは関数である。ふつう関数に引数を複数渡そうと思ったら、ひとつずつカンマ区切りで渡す。
ただ上の例では「vbYesNo + vbQuestion + vbDefaultButton2」と足し算している。

今回はこれの仕組みを解説しようと思う。

MsgBoxでオプションを足し算できる仕組み

まず、それぞれの定数の値をイミディエイトウインドウで確認してみると、4、32、256と出る。

全て足し合わせると、292だ。では292を直接渡してみよう。

Sub hoge()
    MsgBox "処理を続行しますか。", 292, "確認"
End Sub

これでも同じ表示になる。

実はMsgBoxに指定できる定数値は以下のようになっており、これらを一つずつ組み合わせて292を作ろうと思ったら、必然的に「256=vbDefaultButton2」、「32=vbQuestion」、「4=vbYesNo」の組み合わせになるのだ。

定数	値
vbApplicationModal	0
vbDefaultButton1	0
vbOKOnly	0
vbOKCancel	1
vbAbortRetryIgnore	2
vbYesNoCancel	3
vbYesNo	4
vbRetryCancel	5
vbCritical	16
vbQuestion	32
vbExclamation	48
vbInformation	64
vbDefaultButton2	256
vbDefaultButton3	512
vbDefaultButton4	768
vbSystemModal	4096
vbMsgBoxHelpButton	16384
vbMsgBoxSetForeground	65536
vbMsgBoxRight	524288
vbMsgBoxRtlReading	1048576

つまり足し合わせて渡しても、定数表をもとに分解できるということ。
定数値を1、2、4、8、16と倍々にしていくと、それらの組み合わせは元の定数に分解できるのだ。
※一部48や768などの2のn乗になっていないものがあるが、これは32+16、512+256の組み合わせになっている。2進数を学習すると意味が分かると思うのでここでは説明を割愛。

ただし、同じカテゴリのプロパティを足し合わせるとおかしなことになる。

たとえば以下のようにすると、32+16だから、48=vbExclamationと同じことになる。

Sub hoge()
    MsgBox "Hello", vbQuestion + vbCritical
End Sub

こうすると、

Sub hoge()
    MsgBox "Hello", vbYesNo + vbYesNo + vbYesNo + vbYesNo
End Sub

こうなる。

4+4+4+4=16=vbCriticalなので。

自分で同じ仕組みを作って理解する。

さて、では列挙型を使用して自分で同じ仕組みを作ってみよう。
今回は人物の特徴を題材にコードを書いてみた。

まずはEnumで列挙型定数を宣言する。

Enum 人物の特徴
    男性 = 1
    女性 = 2
    裸眼 = 4
    コンタクト = 8
    メガネ = 16
    スリム = 32
    ふくよか = 64
    A型 = 128
    B型 = 256
    AB型 = A型 + B型
    O型 = 512
End Enum

そして、人物の特徴を表示させるためのプロシージャを用意。

Sub 表示(T As 人物の特徴)
    Dim 血液型 As String
    If T >= O型 Then
        血液型 = "O型"
        T = T - O型
    ElseIf T >= AB型 Then
        血液型 = "AB型"
        T = T - AB型
    ElseIf T >= B型 Then
        血液型 = "B型"
        T = T - B型
    Else
        血液型 = "不明"
    End If
    
    Dim 体型 As String
    If T >= ふくよか Then
        体型 = "ふくよか"
        T = T - ふくよか
    ElseIf T >= スリム Then
        体型 = "スリム"
        T = T - スリム
    Else
        体型 = "標準"
    End If
    
    Dim 視力矯正 As String
    If T >= メガネ Then
        視力矯正 = "メガネ"
        T = T - メガネ
    ElseIf T >= コンタクト Then
        視力矯正 = "コンタクト"
        T = T - コンタクト
    ElseIf T >= 裸眼 Then
        視力矯正 = "裸眼"
        T = T - 裸眼
    Else
        視力矯正 = "不明"
    End If
    
    Dim 性別 As String
    If T >= 女性 Then
        性別 = "女性"
        T = T - 女性
    ElseIf T >= 男性 Then
        性別 = "男性"
        T = T - 男性
    End If
    
    MsgBox "この人物の特徴" & vbNewLine _
        & "性別：" & 性別 & vbNewLine _
        & "視力矯正：" & 視力矯正 & vbNewLine _
        & "体型：" & 体型 & vbNewLine _
        & "血液型：" & 血液型
End Sub

このプロシージャでは人物の特徴を大きな値のものから探し、見つかったらその値を引く。残った数値からまた大きな値を探して引くという繰り返しでデータを分解していく。

では実際に呼び出してみよう。

Sub Main()
    表示 メガネ + 男性 + ふくよか + AB型
End Sub

実行すると、足し合わせて渡した値が正しく表示されているのがわかる。

このように合計値を数値で渡しても同じ結果になる。

Sub Main()
    表示 465
End Sub

以上がメッセージボックスのオプションが足し算できる仕組みである。
もしこの仕組みをより詳しく知りたければ、今回私が書いたコードをそのままVBEで手入力してみると良い。入力候補が適切に表示され、VBエディタが定数の計算をよくアシストしてくれるのがわかる。

VBA VBエディタ上から実行できるRGB関数入力用のカラーパレットフォームを作成

ちょっと長めのタイトルになってしまったが、要はこんなの↓を作った。

VBEのメニューからパレットを起動し、目当ての色のラベルをクリックするだけでカーソル位置にRGB関数が挿入される。

きっかけはこちらの記事。（感謝）
chemiphys.hateblo.jp

作りかた

このマクロはVBEで現在カーソルのある位置にRGB関数を挿入する仕様になっているが、通常F5で起動できるのは現在のカーソル位置のマクロである。だからF5だと被操作コードと、操作コードが同一になってしまうというジレンマがあり、やりたいことが実現できない。

そこでまず、マクロをメニューから実行できるようにする。
以下の記事を参照し、アドインを作っておくと良い。
thom.hateblo.jp

そしてこのアドインにユーザーフォームを追加し、オブジェクト名をColorPickerに変更する。

フォームに記述するコードはこちら。変数宣言が抜けてたりプロシージャの名前がhogeのままだったり、まぁ酷いコードなのだが勢いで公開してしまおう。みなさんが作る場合は悪いところをマネしないように。。

Private Const LabelSizeX = 20
Private Const LabelSizeY = 15
Private ColorLabels As Collection
Private Sub UserForm_Initialize()
    Set ColorLabels = New Collection
    hoge
    Me.Height = (LabelSizeY) * 10 - 5
    Me.Width = LabelSizeX * 9 - 4
End Sub

Sub WriteLabel(x, y, color As Long)
    With New EventControl
        Set .AsLabel = Me.Controls.Add("Forms.Label.1")
        With .AsControl
            .Height = LabelSizeY
            .Width = LabelSizeX
            .Left = x * (LabelSizeX - 1)
            .Top = y * (LabelSizeY - 1)
        End With
        With .AsLabel
            .BackColor = color
            .BorderStyle = fmBorderStyleSingle
        End With
        ColorLabels.Add .Self
    End With
End Sub

Sub hoge()
    colorBase = 51
    ColorPallets = Array( _
        Array(5, 0, 0), Array(5, 3, 0), Array(3, 5, 0), _
        Array(0, 5, 0), Array(0, 5, 3), Array(0, 3, 5), _
        Array(0, 0, 5), Array(3, 0, 5), Array(5, 0, 3))

    Dim R, G, B
    For i = 0 To 8
        For j = 0 To 4
            cp = ColorPallets(i)
            R = (cp(0) - j) * colorBase
            G = (cp(1) - j) * colorBase
            B = (cp(2) - j) * colorBase
            If R < 0 Then R = 0
            If G < 0 Then G = 0
            If B < 0 Then B = 0
            WriteLabel 4 - j, i, RGB(R, G, B)
        Next
    Next
    For i = 0 To 8
        For j = 1 To 4
            cp = ColorPallets(i)
            R = (cp(0) + j) * colorBase
            G = (cp(1) + j) * colorBase
            B = (cp(2) + j) * colorBase
            If R > 255 Then R = 255
            If G > 255 Then G = 255
            If B > 255 Then B = 255
            WriteLabel j + 4, i, RGB(R, G, B)
        Next
    Next
End Sub

次にクラスモジュールを挿入し、オブジェクト名を「EventControl」とする。
EventControlのコードはこちら。

Public WithEvents AsLabel As MSForms.Label

Property Get AsControl() As MSForms.Control
    Set AsControl = AsLabel
End Property

Property Get Red()
    Red = &HFF& And AsLabel.BackColor
End Property
Property Get Green()
    Green = (&HFF00& And AsLabel.BackColor) \ 256
End Property
Property Get Blue()
    Blue = (&HFF0000 And AsLabel.BackColor) \ 256 \ 256
End Property

Property Get RGBFuncAsString() As String
    RGBFuncAsString = "RGB(" & Red & ", " & Green & ", " & Blue & ")"
End Property

Private Sub AsLabel_Click()
    ColorPicker.Hide
    Application.VBE.MainWindow.Visible = True
    InsertCode RGBFuncAsString
End Sub

Property Get Self() As Object
    Set Self = Me
End Property

次に標準モジュールを追加し、オブジェクト名を「fnInsertCode」としておく。
コードは以下のプロシージャひとつのみ。

Sub InsertCode(code As String)
    Dim sl As Long, sc As Long, el As Long, ec As Long
    Application.VBE.ActiveCodePane.GetSelection sl, sc, el, ec
    L = Application.VBE.ActiveCodePane.CodeModule.Lines(sl, 1)
    L2 = Left(L, sc - 1) & code & Mid(L, sc)
    Application.VBE.ActiveCodePane.CodeModule.ReplaceLine sl, L2
    Application.VBE.ActiveCodePane.SetSelection sl, sc + Len(code) + 1, sl, sc + Len(code) + 1
End Sub

最後にMenuMacrosモジュールに以下を追加する。
MenuMacrosモジュールは先ほど紹介した記事「VBA 標準モジュールのマクロを読み取って起動時にVBEのメニューに自動登録するアドインを自作する」で作成したもので、ここに登録しておくだけでVBEのMyToolsメニューに追加されるというものだ。

Sub カラーパレットを表示() 'O
    With Application.VBE.ActiveCodePane
        ColorPicker.Show
        .Show
    End With
End Sub

これで準備完了。あとは変更したアドインを保存し、Excelを起動しなおすと冒頭のGIFアニメのように使用できるようになる。

ざっくり解説

今回はいろいろ試行錯誤してたので結構ひどいコードになった。まだまだ整理できそうだけど気力がないのでいったんこの状態で、おおまかに解説する。

まず自動メニュー登録アドインの動作はこんな感じ。

Auto_Openで起動時にMenuMacrosモジュールからマクロのタイトル部を配列として抜き出してきて、それをもとにメニューを作成している。

カラーパレットはこんな感じ。

メニューから起動されフォームがShowされると、まずフォームはカラーラベルを生成し、それをそれぞれ生成したEventControlに保持させる。このEventControlはフォーム内部のコレクションが保持する。ここまでがフォーム表示までの流れ。

それからユーザー操作からフォームクローズまでの流れは青字で書いた。
ユーザーがカラーラベルをクリックするとEventControl内のClickイベントが発火され、fnInsertCodeで現在選択されている箇所にRGB関数が挿入される。

以上で解説を終える。

フローチャートのときもそうだけれど、ある程度複雑になってくると作り方の紹介で精いっぱいで、コードの細かいところまで解説する気力が湧かない。

そして完成させるのが精いっぱいで分かりやすいコードに修正する気力も。。

おまけ

実はカラーラベルは枠線で誤魔化してるんだけど、同じ色の箇所がいくつもあったりして。

Webセーフカラーというものからパレットっぽい色をチョイスしたかったのでRGB値をそれぞれ51の倍数にしようとこだわった結果、無理が出てこうなった。

ラベルは9*9で81枚なので計算で求めようとせずに1枚ずつ愚直にカラーコードを作ってしまっても良いかもしれない。

あ、あとわざわざ自前で作らなくてもWin32APIのカラーピッカーを呼ぶ手もある。

VBA 複数の引数をとるPropertyプロシージャ

これまでProperty Getは複数の引数を受け取ることができないと思っていたが、昨日Twitterで以下のご指摘をいただいた。

@thom__jp https://t.co/pgPwIa8S2p
の記事で少し気になったのですが、PropertyLetは複数の引数をとれる（最後の一つが右辺、残りは左辺のカッコ内）と思ったのですがどうでしょうか？
「クラス.プロパティ(引数1,引数2)=引数3」の形式

— いみひと (@nukie_53) 2017年1月6日

ということで早速実験。

まずClass1を作成して以下を記述。

Property Let Sample(A As Long, B As Long, C As Long)
    Debug.Print A, B, C
    Debug.Print "Letが呼ばれました。"
End Property

Property Get Sample(A As Long, B As Long) As Long
    Debug.Print A, B
    Sample = A + B
    Debug.Print "Getが呼ばれました。"
End Property

Letで引数が3つなのに対し、Getでは2つしかない。
これは、Letの最後の引数がGetの戻り値に対応するためだ。

Propertyプロシージャはふつうプライベート変数に間接的にアクセスするための「アクセサ」として用いるが、今回はとりあえずただのプロシージャとして使う。
↓以下を読んでいただくと意味が分かるかと。
thom.hateblo.jp

次に標準モジュールに以下のコードを書いて実行。

Sub hoge()
    Dim C As Class1: Set C = New Class1
    C.Sample(10, 20) = 30
    Debug.Print C.Sample(10, 30)
End Sub

するとイミディエイトウインドウにこのように出力された。

 10      20     30 
Letが呼ばれました。
 10      30 
Getが呼ばれました。
 40 

ということで、実際に検証したところ複数の引数をとれないと思っていたのは私の勘違いだったようだ。
いみひとさんありがとうございます！

ではこれを使ってもう少し実用的なクラス内部の配列へのアクセスをやってみようと思う。

Class1をこのように書き換える。

Private Arr(1 To 9, 1 To 9) As Long

Property Let Values(x As Long, y As Long, value As Long)
    Arr(x, y) = value
End Property

Property Get Values(x As Long, y As Long) As Long
    Values = Arr(x, y)
End Property

標準モジュールには以下のコードを記述。

Sub 九九()
    Dim C As Class1: Set C = New Class1
    
    '作成処理
    Dim i As Long, j As Long
    For i = 1 To 9
        For j = 1 To 9
            C.Values(i, j) = i * j  'Letが呼ばれる
        Next
    Next
    
    '表示処理
    Dim k As Long, l As Long
    For k = 1 To 9
        For l = 1 To 9
            Debug.Print C.Values(k, l); 'Getが呼ばれる
        Next
        Debug.Print
    Next
End Sub

ただの九九なので普通はこんなややこしいことしないけど、まあそこはサンプルということで。
これでちゃんと複数の引数をとるPropertyプロシージャがオブジェクトの内部配列へのアクセサとして機能することが分かった。

赤字・太字・下線は文章を読みやすくしない

文字飾りが派手になっていくメカニズム

私は普段仕事でシステムの運用手順書などを作成する機会が多い。

手順書は複数人がメンテナンスするので皆さんそれぞれ重要だと思ったところを赤字にしてみたり、太字にしてみたり、下線を引いてみたり、はたまた吹き出しをつけてみたりと、割と好き勝手に編集する。

本当に重要な箇所を際立てるためにフォントを飾り付けて工夫するというのは別に間違っているとは思わないが、問題は「重要」がきちんと定義されていないことだ。

たとえば、

• これはよく忘れがちだから赤字で書いておこう。
• この手順は省略できるので、無駄を省くため目立つように赤字で書いておこう。
• この作業をする理由は非常に重要なことだから、赤字で書いておこう。

このようにして赤字は増え続け、しまいに赤色だけでは目立たないから、本当にクリティカルなところは更に目立つように太字にしたり下線を引いたりする。

赤字・太字・下線は文章を読みやすくしない

確かに赤で書けば目立つ。パッと目に飛び込んでくる。
しかし決して、読みやすくなったわけではない。

これ、読みやすいだろうか。

これは？

バカみたいだと思うかもしれないけど、私の職場では実際にこれに近いことが起きている。

重要→目立たせたい→赤色という条件反射でドキュメントを編集するとこうなる。
まわりがシンプルだから飾ると対比で目立つのであって、「赤＝目立つ」ではない。

• 赤字にすると、目にうるさい。
• 太字にすると、漢字の判別に重要な細かい空間が潰れる。
• 下線を引くと木と本を見間違えたり、字形の判別の邪魔になる。

本来、赤字・太字・下線というのは読みにくいのだ。
赤字・太字・下線を使わないほうが断然読みやすい。

適切に使用する分には、重要な箇所が際立つので文章全体として読みやすさは増す。
この読みやすさとは、赤字そのものの読みやすさではなく、赤字だけを拾い読みすれば重要箇所の概要をつかめるという読みやすさである。

つまり、重要でないところの読み飛ばしやすさが増すということだ。

重要をしっかり定義する

個人のブログだったら自分が重要だと思った箇所や、より強く訴えたい箇所にコントラストをつけてやればよい。たとえば先ほどから例にあげている、赤字・太字・下線だ。

しかし複数人でメンテナンスする業務マニュアルでこれをやってしまうと、赤字・太字・下線のオンパレードになる。なぜなら、書いてあることはすべて重要だからだ。重要じゃないことなんて、そもそも無い。だからたとえば手順を飛ばしてしまったり、間違えるたびに「ここ重要」となる。赤字の割合が黒字を超えると、そのうち赤字しか読まなくなる。

じゃあどうすれば良いかというと、「重要」を個人の感性に任せずに、しっかりケースを定義すればいい。

たとえば以下のような箇所を「重要」と定義する。

• 間違えるとリカバリーが困難な箇所
• 間違えると人に迷惑をかける箇所
• 間違えると費用が発生する箇所
• 間違えたことに気づきにくい箇所
• トラブル時に急いで探す必要のある電話番号

また、以下のような箇所は「赤字にしない」と定義する。

• その作業を実施する経緯や理由
• 間違えてもシステムでエラーになり、やり直せる箇所
• 楽をするための裏ワザやノウハウ

これらが重要ではないとは言わないけれど、そんなところまで赤字にしてしまうと、更に重要な箇所はもっと目立たせようとして最終的に冒頭で紹介したようなことになる。
文字飾りはより重要な箇所に譲り、基本は単調でモノクロな読み疲れしにくいドキュメント作成を心掛けたい。

VBA クラスモジュールでフィールド数の多いデータを扱う

最近読者になったブログにこんなお悩みが。

80以上の要素を持つ４００～５００件のデータをどう扱おうか悩み中。

Powerpoint VBAに触れてみて - chemiphys’s blog

自分ならどうするってのを考えてみたので公開。
やはり人のブログを読むと刺激されて執筆が捗る。

さて今回はサンプルとしておなじみの「なんちゃって個人情報」を使う。
※ダミーデータだが読者に偶然同姓同名がいても気が悪いと思うのでちっちゃく表示。

さて、フィールド数が多い場合、確かにプロパティの準備が面倒くさい。たとえパブリック変数で済ませるにしても80フィールド(つまり80列)となるとさすがにやりすぎな感じ。※今回のデータはサンプルなので14列。

そこで、多数のフィールドの中でも、比較や検索などでよく利用しそうなものだけプロパティを用意し、あとは配列で済ませてしまうということを考えた。

ためしに名前と年齢だけプロパティ化してみる。
クラスモジュールを挿入し、オブジェクト名をPersonに変更して次のコードを張り付ける。

Private Parameter(1 To 14)
Property Get 名前() As String
    名前 = Parameter(1)
End Property
Property Get 年齢() As Long
    年齢 = Parameter(5)
End Property
Property Get Self() As Object
    Set Self = Me
End Property

Sub LetParameter(paramNo, value)
    Parameter(paramNo) = value
End Sub

Function GetParameter(paramNo) As Variant
    GetParameter = Parameter(paramNo)
End Function

なお、配列はオブジェクトのPublic要素にできないので、Private変数として保持させ、アクセサ(LetParameter、GetParameter)で値の設定・取得を行う。
ここでProperty構文を使わなかったのは、LetParameterが2つの引数をとるためだ。Property Letは引数1つまでしか想定されていないので今回のケースでは使えない。
↓Propertyが複数の引数をとれないというのは私の勘違いでした。
thom.hateblo.jp
この記事中のコードは変更しませんが、Property構文を使うとあたかも内部配列に直接アクセスしているかのように扱えるので、上記記事も合わせてお読みください。

さて、入れ物が完成したところで、まずは材料の取得から。

以下の関数を作成し、データを二次元配列で取得できるようにする。

Function GetDataAsArray() As Variant
    GetDataAsArray = Sheets(1).Range("A1").CurrentRegion.value
End Function

Excelはセルへのアクセスが遅いので、一旦配列化しておくとその後の加工は高速に行える。

次に、データをコレクションとして取得できる関数を用意。

Function GetDataAsCollection() As Collection
    Dim arr: arr = GetDataAsArray
    Dim C As Collection: Set C = New Collection
    Dim i, j
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        With New Person
            For j = 1 To 14
                .LetParameter j, arr(i, j)
            Next
            C.Add .Self
        End With
    Next
    Set GetDataAsCollection = C
End Function

この関数は先ほど作成したGetDataAsArrayからデータを読み取り、Personオブジェクトに格納してCollectionに追加する。

最後にメインモジュール。

Sub Main()
    Dim C As Collection: Set C = GetDataAsCollection
    Dim p As Person
    For Each p In C
        If p.年齢 < 30 _
            And p.GetParameter(4) = "女" _
            And p.GetParameter(7) = "未婚" Then
                Debug.Print p.名前
        End If
    Next
End Sub

コレクションをFor EachでまわしながらPersonデータを取出し、30歳未満の未婚の女性を抽出して名前を表示させている。

おっと、ここで4とか7ってのは俗にいうマジックナンバーってやつだ。
放っておくと何のことかわからなくなるので、列挙型定数で定義してやる。

Enum Param
    性別 = 4
    婚姻 = 7
End Enum

すると、メインコードは以下のようになる。

Sub Main()
    Dim C As Collection: Set C = GetDataAsCollection
    Dim p As Person
    For Each p In C
        If p.年齢 < 30 _
            And p.GetParameter(Param.性別) = "女" _
            And p.GetParameter(Param.婚姻) = "未婚" Then
                Debug.Print p.名前
        End If
    Next
End Sub

コーディング中も、「Param.」と入力すると候補が出るので便利。

さて、今回作ったコードを応用して、元データから条件にあった行の必要な列だけを抜き出してみよう。
コードは以下のとおり。

Sub Main2()
    Dim C As Collection: Set C = GetDataAsCollection
    Dim p As Person
    
    Dim C2 As Collection: Set C2 = New Collection
    'このループでCをフィルタリングしてC2へ入れる
    For Each p In C
        If p.年齢 < 30 _
            And p.GetParameter(Param.性別) = "女" _
            And p.GetParameter(Param.婚姻) = "未婚" Then
            C2.Add p
        End If
    Next
    
    Dim RangeArray(): ReDim RangeArray(1 To C2.Count, 1 To 5)
    Dim n As Long: n = 1
    'このループでフィールドを絞りながらシート書き込み用の配列作成
    For Each p In C2
        RangeArray(n, 1) = p.名前
        RangeArray(n, 2) = p.GetParameter(2)    '面倒なので、
        RangeArray(n, 3) = p.GetParameter(11)  'マジックナンバー
        RangeArray(n, 4) = p.GetParameter(9)    '書いちゃいます。
        RangeArray(n, 5) = p.GetParameter(3)    'ごめん！
        n = n + 1
    Next

    'シート2に配列を転記
    Sheets(2).Range("A2").Resize(C2.Count, 5).value = RangeArray
End Sub

このコードでは、シート1→配列→コレクション→フィルタ済みコレクション→配列→シート2と、次々データを変換させていく。

実行すると、条件にあった人の指定した要素だけがシート2へ転記される。

こんな感じで、プログラム中に重要な意味を持つ値だけをプロパティにして、その他を配列として保持させてしまえば素の配列とクラスのいいとこどりハイブリッドなデータ形式になる。

※今回はあくまでサンプルのため、重要な意味を持つかどうかに関係なく適当にプロパティ化しているのであしからず。

VBA 変数宣言で途中改行する

VBAでは、半角スペースに続けてアンダーバーを書くことでステートメントの途中で改行することができる。

実は昔、この途中改行が嫌いだった。理由は単に自分が途中改行されたコードに慣れてなかっただけで、慣れてからガンガン使うようになっている。

たとえば変数宣言。以下のように2行で書くのが主流だ。

    Dim SampleCollection As Collection
    Set SampleCollection = New Collection

私の場合はちょっと前までこのように1行で書いていて、

    Dim SampleCollection As Collection: Set SampleCollection = New Collection

最近はこんな感じのコードも増えてきた。

    Dim SampleCollection As Collection: Set SampleCollection _
        = New Collection

ほんとはVB.Netみたいに

    Dim SampleCollection As New Collection

とか、

    Dim SampleInteger As Integer = 10

という風に書きたいんだけど、VBAの場合は変数宣言と同時にNewすると挙動が変わる問題もあるし、後者のIntegerについてはそもそもそのように書けない。
thom.hateblo.jp

Collection型で宣言してるのでCollection型のインスタンスを入れるのは明白。にもかかわらず改めてSetでNew Collectionと書かなければならない。変数名も型名も2回ずつ書く必要があるので、くどい。

ということで、右半分は無視することにした。

…てのは冗談で、元々は「はてなブログ対策」で考えた記法。

はてなブログには「はてなスーパープレ記法※」という便利な機能があって、>|言語|と||<で括るとその言語のコードを色分けしてくれる。
※ブログの基本設定から編集モードをはてな記法モードにしておく必要あり。

たとえばVBAの場合は>|vb|と||<で括る。

さて、便利なんだけど、コードの場合は文字の折り返しが効かず(それがpreなので)、こんな感じで少し長いコードははみ出してしまう。

いろいろ試してみたけど結局うまくいかないので、あきらめてそもそも一行があまり長くならないようにコーディングするようになった。
（最近はあまり意識できてないけど。）

でもやってみたらこういう風に読めなくもないので、個人的にはアリかなと思っている。

↓以下のコードでよく使っている。
thom.hateblo.jp

まぁこんな書き方で「イイね」と思ってるのはひょっとすると全国で私だけかもしれないけど、私は職業プログラマーでない限りコードの書き方は自由だ(そして自己責任だ)と考えてる※ので、「こんなコードはけしからん」などと思っても所詮アマチュアの戯言だと思っていただければ。

※詳細は以下をご参照ください。
thom.hateblo.jp