ExcelVBAの開発用アドインをGithubで公開してみた

ExcelVBA開発用のアドインをGithubで公開してみたのでご自由にお使いください。
ただしトラブル発生時は自己責任でお願いします。

URLはこちらです。
https://github.com/thom-jp/thoms_ExcelAddIn_for_VBADeveloper

ファイルの直接ダウンロードはこちらです。
https://github.com/thom-jp/thoms_ExcelAddIn_for_VBADeveloper/raw/master/bin/thoms_VBE_AddIn.xlam

利用するにはマクロのセキュリティで以下のチェックを入れる必要があります。

ただしここにチェックを付けるとセキュリティが甘くなります。
この行為が何を意味するのか分かる方のみ、チェックして使ってください。

ただ、今のところできることはこれだけしかありません。

参照設定改は割と使えるんじゃないかと思ってます。
thom.hateblo.jp

カラーパレットはこちらの記事で紹介したものです。
thom.hateblo.jp

インデント調整用のマクロはこちらの記事で紹介したものをベースに、もう少し色々な命令に対応させています。
thom.hateblo.jp

ただ実行すると空行を詰めてしまうので好みは分かれるかもしれません。
以下の設定をしておくと行が詰まってもそれほど見づらくならないのでおすすめです。
thom.hateblo.jp

メニューのベースになっているのはこちらで紹介したマクロです。
thom.hateblo.jp

自分で簡単にマクロを追加できるので、何か良いアイデアがあれば自由に改変していただいて構いません。MITライセンスで公開したので再配布も自由です。ただし改変して再配布する場合はプロジェクト内のどこかしらのモジュールにこのブログのURLをコメントしてください。

以下参考

thom.hateblo.jp

VBAを写経しながらタイピング練習するツールを作成

今回作成したのは、以下のようなツール。
※GIFアニメなので読み込み終わって動き出すまで時間かかるかもしれません。

サンプルコードが表示され、その通りに入力していくだけのシンプルなものであるが、次に入力すべきキーとそれを押す指の名前が赤く表示される。間違えると入力欄が赤くなる。

経緯

プログラミングを覚えるには、とにかくたくさんコードを手入力することが大切である。
thom.hateblo.jp

ここでキー入力が速いと数をこなすことができるので、上達も早くなる。
しかし最近出会ったとある方はプログラミングをやりたいけれどまだタッチタイプが出来ないという。その方はまだ20代。
若者は皆パソコンを使いこなすと思っていたんだけれど、ひょっとするとスマホの登場でそういう時代はもうとっくに終わったのかもしれない。

昔は一家に一台パソコン、そのあとに一人に一台パソコンの時代（持ってなかった方、ゴメン）と言われていたんだけれど、タッチデバイスの普及によってパソコン初心者は逆に増えているのかもしれない。

でもスマホの普及で逆に万人がアプリ、つまりソフトウェアを日常的に便利に使うようになっているので、自分で作ってみたいという方も増えてくるハズ。

となるとやはりパソコンが使うハメになるわけで、まずはタッチタイプから覚えていくことになる。でもどうせやるならコードを書きながらタッチタイプを覚えたいよね。

というのが作成の経緯。

中身のコード

プロトタイプなので見せられたものではないが、見せてしまおう。
コードはすべてフォームに記載している。この時点で設計としてはよろしくないのだけれど、まぁ今回は適当に。。

フォームのパーツはこんな感じ。

あれ、キーは？と思われるかもしれないが、キーのラベルは手で配置するのが面倒なのでフォームを起動したときに自動で生成されるようにコードで書いている。

フォームのコードはこんなかんじ。きったなーい。

Private KeyCollection As Collection
Const KeyLabels = "1234567890-^\qwertyuiop@[asdfghjkl;:]zxcvbnm,./\"
Const ShiftLabels = "!""#$%&'()　=~|QWERTYUIOP`{ASDFGHJKL+*}ZXCVBNM<>?_"
Const Fingers = "123344556788812344556788812344556788812344556788"
Const FingerNames = "小指 薬指 中指 人差し指 人差し指 中指 薬指 小指"
Private Sub TextBox1_Change()
    x = Mid(Label1.Caption, Len(TextBox1.Text) + 1, 1)
    Call AssignKey(InStr(1, ShiftLabels, x) > 0)
    
    Dim a: a = InStr(1, KeyLabels, x)
    If a = 0 Then a = InStr(1, ShiftLabels, x)
    lblLeftHand.Caption = ""
    lblRightHand.Caption = ""
    If a <> 0 Then
        Index = CLng(Mid(Fingers, a, 1)) - 1
        cap = Split(FingerNames)(Index)
        If Index >= 4 Then
            lblRightHand.Caption = cap
        Else
            lblLeftHand.Caption = cap
        End If
    End If
        
        
    
    Dim C As MSForms.Control
    For Each C In Me.Controls
        If TypeName(C) = "Label" Then
            If Len(C.Caption) = 1 Then
                C.BackColor = vbWhite
                If C.Caption = x Then
                    C.BackColor = vbRed
                End If
            End If
        End If
    Next
    If TextBox1.Text <> Left(Label1.Caption, Len(TextBox1.Text)) Then
        TextBox1.BackColor = vbRed
    Else
        TextBox1.BackColor = vbWhite
    End If
End Sub

Private Sub UserForm_Initialize()
    Set KeyCollection = New Collection
    Call CreateLabels
    Call TextBox1_Change
End Sub

Sub AssignKey(Optional shift As Boolean = False)
    If shift Then
        lblShiftR.BackColor = vbRed
        lblShiftL.BackColor = vbRed
    Else
        lblShiftR.BackColor = vbWhite
        lblShiftL.BackColor = vbWhite
    End If
    Dim str: str = IIf(shift, ShiftLabels, KeyLabels)
    For i = 1 To KeyCollection.Count
        KeyCollection(i).Caption = Mid(str, i, 1)
    Next
End Sub

Sub KeyActivate(C As String)
    Dim loc As Variant
    loc = InStr(1, KeyLabels, C, vbBinaryCompare)
    KeyCollection(loc).BackColor = vbRed
End Sub

Sub CreateLabels()
    OffsetY = 10
    OffsetX = 10
    
    arr = Array(12, 11, 11, 10)
    Dim L As MSForms.Label
    Dim C As MSForms.Control
    For j = 0 To 3
        For i = 0 To arr(j)
            Set L = Me.Controls.Add("Forms.Label.1")
            Set C = L
            L.Font.Size = 30
            L.BackColor = vbWhite
            L.TextAlign = fmTextAlignCenter
            C.Width = 30
            C.Height = 30
            C.Top = j * (C.Height + 5) + OffsetY
            C.Left = i * (C.Width + 5) + OffsetX
            KeyCollection.Add C
        Next
        OffsetX = OffsetX + (C.Width \ 2)
    Next
    Set L = Me.Controls.Add("Forms.Label.1")
    Set C = L
    L.Font.Size = 30
    L.BackColor = vbWhite
    L.TextAlign = fmTextAlignCenter
    L.Caption = " "
    C.Width = 100
    C.Height = 30
    C.Top = j * (C.Height + 5) + OffsetY
    C.Left = 3 * (35) + OffsetX
    
End Sub

変数宣言もしてたりしてなかったり、変数名もあまりよく考えずにつけている。似たようなものを作りたい方がいたらパクってもらって良いけど、汚いコードまでマネしないように。。

気力が乗ったら綺麗に整理しなおそう。

そしてフォームに表示させるサンプルコードはまさかの直書きである。
「次の練習コード」などのボタンをつけるつもりなんだけれど、まだその部分は考えてなくて未実装。

まぁ、試作品みたいなものなので大目に見てもらおう。

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プロシージャがオブジェクトの内部配列へのアクセサとして機能することが分かった。

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

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

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

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

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

たとえば、

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

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

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

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

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

これは？

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

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

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

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

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

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

重要をしっかり定義する

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

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

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

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

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

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

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

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