Excel VBAでスクロール可能なフォームのアイデア

Excel VBAでフォームを作る際に、項目が多くてウインドウの高さに収まりきらないことがある。
そこで今回はスクロールによってフォーム全体をウインドウに収めるアイデアを紹介する。

言葉では何がやりたいのか伝わりにくいと思うのでまずは動作イメージから。

動作イメージ

注意事項

あくまでアイデアなので、実用化にはまだ色々と工夫が必要になる。
今のままではデータの取り出しすらままならないのだが、本記事のコードを読める人なら自分で実装できると思われる。

コード

クラスモジュール「FieldLocator」

まずはクラスモジュールを挿入し、オブジェクト名をFieldLocatorとする。
このFieldLocatorはデータフィールド用のテキストボックスとそのラベルを生成し、座標を管理するオブジェクトだ。
最初のFieldLocatorから次のFieldLocatorへ、そこからまた次のFieldLocatorへと参照が張られ、とリスト構造(数珠状)でつながる仕組み。
1カラムのテキストボックス、2カラムのテキストボックスのみ対応している。

コードはこちら。

'DEBUG_MODEはラベルを配置するときに色が付いてないとサイズが分かりづらいので作った。
'Falseにすると色付け無しになる。
#Const DEBUG_MODE = False
Private top_ As Long
Public Left As Long
Public FieldName1 As String
Public FieldName2 As String
Public LabelWidth As Integer
Public LineCount As Integer
Public L1 As MSForms.Label, L2 As MSForms.Label
Public T1 As MSForms.TextBox, T2 As MSForms.TextBox

'すべてのFieldLocatorは最初のアイテムからNextItemを辿って数珠状につながる想定。
'これにより、最初のアイテムのTopプロパティーを変更すると、連鎖的に他のアイテムのTopプロパティーも変わる。
'つまり全てのコントロールが最初のアイテムに連動して動くので、スクロールバーで動かすのは最初のアイテムだけでOKになる。
Public NextItem As FieldLocator

Const FONT_SIZE = 12, FONT_HEIGHT = 15, FONT_MARGIN = 6

Private Sub Class_Initialize()
    Me.LineCount = 1
    Me.LabelWidth = 100
End Sub
Public Property Get Self() As FieldLocator
    Set Self = Me
End Property

Public Function CreateNext() As FieldLocator
    With New FieldLocator
        .Top = Me.Bottom + 10
        .Left = Me.Left
        .LabelWidth = Me.LabelWidth
        Set NextItem = .Self
        Set CreateNext = NextItem
    End With
End Function

Public Property Let Top(t_ As Long)
    top_ = t_
    If Not T1 Is Nothing Then
        CCnt(T1).Top = t_
        CCnt(L1).Top = CCnt(T1).Top + 2
        If Not T2 Is Nothing Then
            CCnt(T2).Top = CCnt(T1).Top
            CCnt(L2).Top = CCnt(L1).Top
        End If
    End If
    If Not NextItem Is Nothing Then
        NextItem.Top = Me.Bottom + 10
    End If
End Property
Public Property Get Top() As Long
    If T1 Is Nothing Then
        Top = top_
    Else
        Top = CCnt(T1).Top
    End If
End Property
Public Property Get Bottom() As Long
    Bottom = CCnt(T1).Top + CCnt(T1).Height
End Property

Sub AddInputBox(f As UserForm)
    Set L1 = f.Controls.Add("Forms.Label.1")
    L1.Font.Name = "Meiryo UI"
    L1.Font.Size = FONT_SIZE
    CCnt(L1).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L1).Width = LabelWidth
    CCnt(L1).Left = Left
    L1.TextAlign = fmTextAlignRight
    L1.Caption = FieldName1
#If DEBUG_MODE Then
    L1.BackColor = rgbLightYellow
#End If
    
    Set T1 = f.Controls.Add("Forms.Textbox.1")
    T1.BorderStyle = fmBorderStyleSingle
    T1.Font.Name = "Meiryo UI"
    T1.Font.Size = FONT_SIZE
    T1.MultiLine = LineCount > 1
    T1.ScrollBars = fmScrollBarsVertical
    T1.EnterKeyBehavior = LineCount > 1
    CCnt(T1).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T1).Width = 450
    CCnt(T1).Left = CCnt(L1).Left + CCnt(L1).Width + 10
    CCnt(T1).Top = top_
    
    CCnt(L1).Top = CCnt(T1).Top + 2
End Sub

Sub AddTwinInputBox(f As UserForm)
    Set L1 = f.Controls.Add("Forms.Label.1")
    L1.Font.Name = "Meiryo UI"
    L1.Font.Size = FONT_SIZE
    CCnt(L1).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L1).Width = LabelWidth
    CCnt(L1).Left = Left
    L1.TextAlign = fmTextAlignRight
    L1.Caption = FieldName1
#If DEBUG_MODE Then
    L1.BackColor = rgbLightYellow
#End If

    Set L2 = f.Controls.Add("Forms.Label.1")
    L2.Font.Name = "Meiryo UI"
    L2.Font.Size = FONT_SIZE
    CCnt(L2).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L2).Width = LabelWidth
    L2.TextAlign = fmTextAlignRight
    L2.Caption = FieldName2
#If DEBUG_MODE Then
    L2.BackColor = rgbLightYellow
#End If
    
    Set T1 = f.Controls.Add("Forms.Textbox.1")
    T1.BorderStyle = fmBorderStyleSingle
    T1.Font.Name = "Meiryo UI"
    T1.Font.Size = FONT_SIZE
    T1.MultiLine = LineCount > 1
    T1.ScrollBars = fmScrollBarsVertical
    T1.EnterKeyBehavior = LineCount > 1
    CCnt(T1).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T1).Width = (450 - 20 - LabelWidth) / 2
    CCnt(T1).Left = CCnt(L1).Left + CCnt(L1).Width + 10
    CCnt(T1).Top = top_
    
    CCnt(L1).Top = CCnt(T1).Top + 2
    CCnt(L2).Left = CCnt(T1).Left + CCnt(T1).Width + 10
    CCnt(L2).Top = CCnt(L1).Top
    
    Set T2 = f.Controls.Add("Forms.Textbox.1")
    T2.BorderStyle = fmBorderStyleSingle
    T2.Font.Name = "Meiryo UI"
    T2.Font.Size = FONT_SIZE
    T2.MultiLine = LineCount > 1
    T2.ScrollBars = fmScrollBarsVertical
    T2.EnterKeyBehavior = LineCount > 1
    CCnt(T2).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T2).Width = CCnt(T1).Width
    CCnt(T2).Left = CCnt(L2).Left + CCnt(L2).Width + 10
    CCnt(T2).Top = top_
End Sub

Private Function CCnt(o As Object) As MSForms.Control
    Set CCnt = o
End Function

フォームモジュール

ユーザーフォームを挿入し、次のコードを張り付ける。
フォームのオブジェクト名は任意で良い。

Dim FirstField As FieldLocator
Private WithEvents ScrollBar1 As MSForms.ScrollBar
Private Sub ScrollBar1_Change()
    'ScrollBarはマイナス値をMaxに設定すると、増分がマイナスになるので、
    '次のようにシンプルに書ける。
    FirstField.Top = ScrollBar1.Value
End Sub

Private Sub UserForm_Initialize()
    Set ScrollBar1 = Me.Controls.Add("Forms.ScrollBar.1")
    Const GOLDEN_RATIO = 1.618
    Me.Width = 800 '所有してるモニタの最低解像度の横幅が800(SVGA)なので。ちなみに最高は1920。
    Me.Height = Me.Width / GOLDEN_RATIO '黄金比を用いて収まりよく。
    ScrollBar1.Width = 20
    ScrollBar1.Left = Me.Width - 25
    ScrollBar1.Height = Me.Height - 22
    ScrollBar1.SmallChange = 5
    ScrollBar1.LargeChange = 20
    With New FieldLocator
        '最初の作成で設定する
        Set FirstField = .Self
        .Top = 30
        ScrollBar1.Min = .Top
        .Left = 100
        .LabelWidth = 80
        
        '以降の設定項目は共通
        .FieldName1 = "件名"
        .LineCount = 1 'LineCountは省略すると1になる。
        .AddInputBox Me 'これは1カラムの入力フィールドを追加するコマンド
        
    '以降はCreateNextのメソッドチェーンでFieldLocatorを数珠状に作っていく。
    With .CreateNext
        .FieldName1 = "概要"
        .LineCount = 2
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "詳細"
        .LineCount = 10
        .AddInputBox Me
    With .CreateNext
        '2カラムの入力フィールドの場合はこうする。
        .FieldName1 = "開始日"
        .FieldName2 = "有効期限"
        .AddTwinInputBox Me
    With .CreateNext
        .FieldName1 = "担当者"
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "連絡先"
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "備考欄"
        .LineCount = 10
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "その他"
        .AddInputBox Me
        
        '最後の要素のBottomを利用してScrollBarのMax値
        '(プロパティ名はMaxだが、実際にはマイナス値なので最小)を決定する。
        ScrollBar1.Max = Me.Height - .Bottom - 30
    
    'メソッドチェーンが終わると、残念ながら大量のEnd With文
    End With: End With: End With: End With: End With: End With: End With: End With
End Sub

フォーム自体を除き、パーツはすべてコードで生成する為、フォーム上には何も配置しなくて良い。
サイズもコードで指定するのでそのままで良い。
フォームを起動すると冒頭の動作イメージのとおり操作できる。

あとがき

Access Formを使えばこんなことは朝飯前なんだけど、Excelにちょっとしたフォームが欲しくなることもある。
標準のフォーム機能ってのもあった気がするけど、使い勝手がとても悪いので、自作を試みているところ。

ちょっとしたフォームにしては作り方が大掛かりに見えるかもしれないが、使いまわしができ、デザインの微調整が必要なく、単に項目を指定していくだけで完成する汎用的なフォーム作成が目的なので、この手間は仕方がない。

おまけ

以下はスクロールバーをMin 0% Max 100%のパーセンテージで管理しようともがいてる図。

結局、Maxをマイナス値にするとマイナスに向かって進むことが判明し、コードをよりシンプルに出来るのでパーセンテージ管理は没になった。

以下はHeight Managerというオブジェクトでラベルとテキストボックスを管理し、双方向ポインタで結ぶことで先頭を動かすと全体が動く仕組みを作ろうとした図。

このアイデアは別の形(FieldLocator)で実現した。実際には片方向ポインタで十分だった。
上下のボーダーを跨ぐとコントロールを非表示にするアイデアだったが実装に至っていない。

現在はスクロールによってフォームの上端・下端でコントロールが見えなくなるが、本当はZOrderをトップにしたラベルの下に潜り込ませて、完全に潜ったらHiddenにしようと考えている。ちょっと管理すべき項目が多くて混乱中。

VBA 連続して与えられた数の最大値、最小値を求めるクラス

今回は連続して値を投げ込み、その最大値・最小値を求めるクラスを紹介する。
かなりシンプルなのでわざわざ記録しておくこともないかなと迷ったけど、クラス初心者向けにはちょうど良いサンプルになりそうなのでとりあえず。

クラスモジュールのコード

クラス名はNumericAggregationObjectとし、次のコードを張り付ける。

Public Data As Collection
Public Max As Variant
Public Min As Variant
Public Sum As Variant
Public Property Get Avg() As Variant
    Avg = Sum / Data.Count
End Property

Sub Add(x As Variant)
    If Data.Count = 0 Then
        Max = x
        Min = x
    End If
    If Max < x Then Max = x
    If Min > x Then Min = x
    Sum = Sum + x
    Data.Add x
End Sub

Private Sub Class_Initialize()
    Set Data = New Collection
    Max = 0
    Min = 0
    Sum = 0
End Sub

まぁ見ての通り、オブジェクト外からデータ書き換えし放題のゆるゆるクラス。
個人で使うには十分だけど、クリティカルな業務で使おうと思ったらPropertyでアクセサ作って不正データブロックするなり、もう少しセキュアにした方が良い。

使い方

こちらのサンプル参照。

Sub Sample()
    Dim nao As NumericAggregationObject
    Set nao = New NumericAggregationObject
    nao.Add 10
    nao.Add 12
    nao.Add 9
    Debug.Print "Max:" & nao.Max
    Debug.Print "Min:" & nao.Min
    Debug.Print "Sum:" & nao.Sum
    Debug.Print "Avg:" & nao.Avg
End Sub

動機

これを作った動機はExcel VBAのユーザーフォーム設計で、テキストボックスの最適幅を求める課題が生じたこと。

Meiryo UIはプロポーショナルフォントなので、テキストの内容によって幅が伸縮する。
以前は以下のテキストを使用して幅を作っていたんだけど、実際に自然な文章を入れてみると幅が結構ズレるので、今回は実際の文章を使って最大幅を見つけることにした。
"■■■■■□□□□□■■■■■□□□□□■■■■■□□□□□■■■■■□□□□□"

どうやってやったかは、以下のとおり。

1) ブログから適当な文章を持ってきてSheet1のA1セルに張り付ける。

2) 改行を除去


3) 以下の記事から幅取得用のモジュールを準備
thom.hateblo.jp
※使うのはMeasureTextWidth関数
4) 80バイト切り出したときの最大幅を取得

Sub 最大幅取得()
    Dim t As String
    t = String(80, "*")
    Dim n As Long: n = 1
    Dim nao As NumericAggregationObject
    Set nao = New NumericAggregationObject
    Do While LenB(t) >= 80
        t = MidB(Sheet1.Range("A1"), n, 80)
        w = MeasureTextWidth(t, "Meiryo UI")
        nao.Add w
        n = n + 2
    Loop
    Debug.Print nao.Max
End Sub

実行結果は283と出た。

5) 最大幅に合致する文を取得

Sub 最大幅に合致する文を取得()
    Const 最大幅 = 283
    Dim t As String
    t = String(80, "*")
    n = 1
    Do While LenB(t) >= 80
        t = MidB(Sheet1.Range("A1"), n, 80)
        w = MeasureTextWidth(t, "Meiryo UI")
        If w = 最大幅 Then Debug.Print t
        n = n + 2
    Loop
End Sub

実行結果は「の呼び出し履歴は、一番上が中断したプロシージャ、二番目がその呼び出し元、三番目が」となった。

6) この文をテキストボックスのTextプロパティに入れて、ぎりぎり入る幅にする。
テキストボックスのWidthプロパティを見て、キリの良い数字に切り上げる。(450にした)

以上

これでまぁ大半のテキストはうまく収まると思われる。

ちなみにこれで、私が作るユーザーフォームは基準値が出そろった。

Font.Name	Meiryo UI
Font.Size	12
BorderStyle	fmBorderStyleSingle
Height	15 × 行数 + 6
Width(最大)	450(1カラムレイアウト時)

Heightの計算式の根拠については以下の記事を参照
thom.hateblo.jp

Font.Sizeの根拠については以下の記事を参照
thom.hateblo.jp

VBA 呼び出し履歴を使ったデバッグ

VBEditorには呼び出し履歴という機能がある。

たとえば、プロシージャProcAからプロシージャProcBを呼び出した際にProcBで実行時エラーを吐いて中断したとする。
このとき、中断モードでプロシージャ呼び出しを遡ることができる機能である。

本記事ではこれを使ったデバッグテクニックを紹介する。

まず次のコードを実行してみる。

Sub ProcA()
    For i = -5 To 5
        Call ProcB(i)
    Next
End Sub

Sub ProcB(x)
    Debug.Print 100 / x
End Sub

するとゼロ除算エラーが発生する。ここでデバッグをクリックすると、

エラーが発生した行で中断モードになる。

ここでxが0だからエラーになったのは自明である。
カーソルを乗せるか、イミディエイトウインドウで「?x」と入力すればxが0であることが分かる。

しかしなぜxが0になったのかが分からないことも多い。
今回はサンプルなのでiが0だからに決まってるじゃないかと思われるかもしれないが、実務コードは複雑なのですぐに気づかないこともある。

しかし、この状態でイミディエイトウインドウで「?i」と入力しても、空文字が返るだけ。
呼び出し元のiを知るには、iにカーソルを当てるという方法もあるが、もう少し複雑な検証をしたい場合もある。

ここで呼び出し元スコープに戻るためには、Ctrl+Lで呼び出し履歴ウィンドウを開く。(表示メニューからでもOK)

この呼び出し履歴は、一番上が中断したプロシージャ、二番目がその呼び出し元、三番目がさらにそれの呼び出し元というふうに下に行くほど呼び出しを遡ることができる。

呼び出し元を表示させると、グリーンのカーソルで呼び出し元コードが示される。このときローカルウインドウを表示させると呼び出し元スコープ(ProcA)の変数が表示されているのが分かる。

つまり呼び出し履歴を使用することで、実行エラー発生する条件を呼び出し元に遡って分析することができる。

ここでProcAのiは参照渡しでProcBのxに格納されているので、ローカルウインドウやイミディエイトウインドウで直接値を書き換えると、xの値も変わる。試しにiを1に書き換えてからF5キーで続行すると正しくマクロ実行を継続することができる。
※もし値渡しだった場合は呼び出し元のProcAでiを書き換えてもxは書き換わらないので注意。

以上

VBA Debug.Print、Debug.Assertの代用クラス案

Debug.Print、Debug.Assertはいずれもデバッグ用の機能なので、リリース版のコードには不要である。
かといって消してしまうと、次にコードを修正するときに面倒なので残しておきたい。

そこで代用クラスを作ってみたので紹介。

まずクラスモジュールを挿入し、オブジェクト名をTesterにする。
コードは次のとおり。

#Const VALID = True
Const STOP_ON_ASSERTION_FAILURE = False

Sub Out(v As Variant)
    #If VALID Then
        Debug.Print v
    #End If
End Sub

Sub Assert(exp As Boolean, Optional message As String = "Undefined")
    #If VALID Then
        If Not exp Then
            Out "Assert Failure:" & message
            If STOP_ON_ASSERTION_FAILURE Then
                Stop
            End If
        End If
    #End If
End Sub

Sub Never(exp As Boolean, Optional message As String = "Undefined")
    #If VALID Then
        If exp Then
            Out "Unexpected Occured:" & message
            If STOP_ON_ASSERTION_FAILURE Then
                Stop
            End If
        End If
    #End If
End Sub

これをエスポートする。

そしてテキストエディタでAttribute VB_PredeclaredId = FalseとなっているところをTrueに変更する。

元あったTesterクラスは開放し、編集後のTester.clsをインポートする。

これで、変数宣言やインスタンスセットを省略できる。

使用方法

Assert命令はBoolean型の式を第一引数にとり、Falseであればイミディエイトウインドウにアサート失敗を告げるメッセージを出力する。また、オプションで第二引数の文字列をアサート失敗メッセージとすることもできる。

Never命令はAssertの逆で、Trueであればイミディエイトウインドウにメッセージを出力する。

Out命令は単にDebug.Printと同等である。

以下は使用例。

Sub hoge()
    Tester.Assert 1 = 2, "one is not two"
    Tester.Out "test message"
    Tester.Never 1 = 1, "one is one"
    Debug.Print "hoge"
End Sub

Debug.Assertと同様に失敗時にコードを停止させるには、TesterクラスのSTOP_ON_ASSERTION_FAILUREをTrueに設定する。

ただし、クラスモジュール内部で処理が停止してしまう。

このとき、Ctrl+Lで呼び出し履歴ウインドウを表示できるので、カーソルキーの↓で一つ下を選び、Enterで決定すると、

どこでコケたのかが分かる。

リリース時は、TesterクラスのVALIDをFALSEにするのを忘れずに。

VBA アサーションチェックとは

最近Twitterで何件か、Debug.Assertについて語られているのを見かけたので乗っかってみる。

Debug.Assertの使い方自体は以下で述べたので今回はその意義を中心に説明してみようと思う。
thom.hateblo.jp

アサートとは

Assertという英単語には、主張する・断言する・力説する・表明するといった意味がある。

例) "He asserted he is innocent." → 彼は無実を主張した。

Assertionはそれを名詞化したもので、そのまま主張・断言・力説・表明といった意味。

アサーション機能とは

プログラム言語におけるアサーション機能とは、
「ここはこうなるはずである」という主張・表明をコードとして記述するための命令文を指す。
VBAでは、Debug.Assertという命令が用意されている。

アサーションチェックとは

このアサーションを活用して、バグを炙り出すテクニックをアサーションチェックという。
具体的にどうやるのかは冒頭で紹介した記事を参照して欲しい。

大事なこと

Debug.Assertはあまり見慣れないためか、機能と挙動に着目されることが多い。
でも、そこで終わってはもったいない。

大事なのは、「何のための機能か」である。
挙動だけなら、ウォッチウインドウやIf文で代用できる。

あえてDebug.Assertを使うからには、それは「主張・表明」であって欲しいということ。

Ifやウォッチウインドウは、「どうなったらどうする」という記述はできるが、各ケースは中立でありそれ以上は語っていない。

一方、Debug.Assertは、「条件式の結果はTrueに帰結すべきであるし、当然そうなるはずだ、でなればバグだ」という強い主張を読み取ることができる。

まぁそんな気負わずにさくっと使ってもいいんだけど、原則としてAssertは主張・表明であるということを覚えておくと良い。

使用例

まずは王道のユニットテスト。
thom.hateblo.jp

それから、ループでブックの閉じ忘れを予防するアサーション。
thom.hateblo.jp

関数をリファクタリングした後の、同等性チェック。
thom.hateblo.jp

以上

VBA ユーザーフォームでDual Listboxを作成

今回紹介するのは、複数アイテムの選択でよく見かけるDual Listbox UI。

一応説明しておくと、左のリストからアイテムを選択し、右へ移動させ、最終的に右にあるものが選択したアイテムとして扱われるユーザーインターフェースだ。

構造はそれほど難しくないが、作ってみたら意外に手間だったので記事に残しておく。

フォームデザイン

各部のオブジェクト名は次のとおり設定する。

AvailableListBoxとSelectedListBoxには次の値を設定する。

BorderStyle	1 - fmBorderStyleSingle
MultiSelect	2 - fmMultiSelectExtended

その他、全コントロールのフォントをMeiryo UIに設定する。

TabIndexは次のように設定したが、適宜お好みで良いと思う。

コード

フォームモジュール DualListBoxForm のコード

このコードのポイントは外部から直接フォームをShowさせるのではなく、OpenForm関数の呼び出しによってフォームモジュール内部からShowさせていること。

通常はメインコードでモーダルフォームをShowし、フォーム操作の後にフォームをHideする。
そのフォームで選択された結果を取得するコードもメインコードに書かなければならない。
しかし今回の方法なら、モーダルフォームのクローズから状態取得までを関数に内包させることができ、メインコードが汚れずに済む。

Option Explicit
Public OKClicked As Boolean

Public Function OpenForm(string_collection As Collection, Optional caption_ As String = "Dual ListBox") As Collection
    Me.Caption = caption_
    Dim ret As Collection
    Dim s
    For Each s In string_collection
        AvailableListBox.AddItem s
    Next
    Me.Show
    If OKClicked Then
        Set ret = New Collection
        Dim i As Long
        For i = 0 To SelectedListBox.ListCount - 1
            ret.Add SelectedListBox.List(i)
        Next
    Else
        'ret keeps Nothing
    End If
    Set OpenForm = ret
    Unload Me
End Function

Private Sub AddButton_Click()
    MoveSelectedItems AvailableListBox, SelectedListBox
End Sub

Private Sub AvailableListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    MoveSelectedItems AvailableListBox, SelectedListBox
End Sub

Private Sub RemoveButton_Click()
    MoveSelectedItems SelectedListBox, AvailableListBox
End Sub

Private Sub SelectedListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    MoveSelectedItems SelectedListBox, AvailableListBox
End Sub

Private Sub AddAllButton_Click()
    MoveSelectedItems AvailableListBox, SelectedListBox, True
End Sub

Private Sub RemoveAllButton_Click()
    MoveSelectedItems SelectedListBox, AvailableListBox, True
End Sub

Private Sub OKButton_Click()
    OKClicked = True
    Me.Hide
End Sub

Private Sub CancelButton_Click()
    Me.Hide
End Sub

Private Sub MoveSelectedItems(from_list As MSForms.ListBox, to_list As MSForms.ListBox, Optional target_all As Boolean = False)
    Dim i As Long
    For i = from_list.ListCount - 1 To 0 Step -1
        If from_list.Selected(i) Or target_all Then
            Dim j As Long
            For j = 0 To to_list.ListCount - 1
                If to_list.List(j) >= from_list.List(i) Then
                    Exit For
                End If
            Next
            to_list.AddItem from_list.List(i), j
            from_list.RemoveItem i
        End If
    Next
End Sub

標準モジュールのコード

DualListBoxの選択結果をイミディエイトウインドウに出力するコードを書いてみた。
フォームモジュールのOpenForm関数にString型データの入ったコレクションを渡すとAvailableListに表示され、フォームを閉じるとSelectedListの内容がコレクションで返る仕組み。

Sub hoge()
    Dim c As Collection: Set c = New Collection
    For i = Asc("A") To Asc("E")
        c.Add Chr(i)
    Next

    'フォームを開き、操作結果を取得
    Set c = DualListBoxForm.OpenForm(c)
    
    If Not c Is Nothing Then
        For Each s In c
            Debug.Print s
        Next
    End If
End Sub

リストの準備と返ってきたリストの処理色々ごちゃごちゃやってるように見えるが、フォームからのデータ取得はたったの一行で済む。使い勝手はMsgBoxやInputBoxに近づいたと思う。

あとがき

実際に使ってみて、ボタンの並び順をちょっと失敗したかなと思った。
選択したものだけを移動したいときに、間違えて先頭にあるAddAllButtonを押してしまう。
Add, Remove, AddAll, RemoveAllの順の方が使いやすいかも。
でも記事書いちゃったのでこれはこれで。。

以上

VBA 繰り返される定常業務の工数を見える化するアイデア

サービス業において、業務工数を見える化するというのはとても難しい。
実績ベースで工数入力をしている職場は多いと思うけど、実際のところその方法は担当者の匙加減で何とでもなってしまう。

工数分析をしようと思ったら、工数は理論値で出して、実績との乖離をヒアリングによって突き止めるのが良いと思う。
それで今回は、以下のようなタスクごとの工数値を管理する表を考えてみた。

これをVBAで集計処理することで、担当者ごとの日々の工数をグラフ化する。
すると、年間を通してスタッフごとの繁忙期・繁忙曜日などが見えてくる。

※スタッフの工数にあまり偏りが無いのは、業務を調整したあとでスクリーンショットを取った為。

ベースになるExcel表の解説

コードを紹介する前に、Excel表から解説する。

まず冒頭の表は1業務を1行で表している。
ヘッダーの上に薄い文字でManとかSelectとかCalcと書かれているのは、Manが手入力項目、Selectが選択項目、Calcが自動計算項目であることを表す。

一番目の項目群(Basic Information)について

単にタスクの情報を書いているだけなので、工数管理に直接影響はない。

二番目の項目群(Workload)について

Workload per Cycleは、その業務1回ごとの標準的な工数を分単位で記入する。
ここで、何をもって1回とするかも重要で、明細数によって工数が左右される場合は、1明細を1回とすれば良い。
たとえばID管理業務などで、1依頼につき、複数名が含まれる場合、1名登録に何分かかるかを書く。

次にMonthly Occasionは、その業務が月に何回発生するかを記入する。
Dailyなら20、Weeklyなら4、Monthlyなら1、Quarterlyなら=1/4、Annuallyなら=1/12と入力する。

リクエストベースの業務は見積もりが難しいので、昨年実績があれば12カ月で等分すればよい。
これでMonthly Workload(月間工数)とAnnually Workload(年間工数)が自動計算される。

(ここでAnnually(年次の意味)をAnnualy(エルがたりない)と間違えて書いてたことが発覚したけどスクリーンショット取ってしまったので、まぁいいや。。)

三番～六番目の項目群(Ratio of xxxx)について

これは、業務工数の偏りを比率で表すものである。1を100%として実数で記入する。
たとえば年間を通じてコンスタントに行う業務であれば、Ratio of each monthesは各月 = 1/12になる。(つまり0.08)
年次で9月だけ行うような業務であればSepが1で他は0となる。

Ratio of each weeksは週ごとの偏りを表す。
ただしここでいう週はその月の何週目ではなくて、第3木曜日などと言ったときの3のことである。
たとえば2019年3月21日は、3月の第四週目に位置するが、第三木曜日と呼ばれるので、ここでいう3rd Weekに相当する。

ちなみにこの記事の前に公開した以下の記事は今回の記事の布石だった。
thom.hateblo.jp

Ratio of each day of the weekは曜日ごとの偏りを表す。

最後にRatio of each staffsはスタッフごとの業務分担率を表す。

いずれの項目群もトータル値は1に近似しなければならない。

コードの紹介

まずタスクの一覧シートはオブジェクト名をTaskSheetとしておく。
それから出力シートはオブジェクト名をOutputSheetとしておく。

※オブジェクト名についてはこちらを参照
thom.hateblo.jp

OutputSheetのコード

Option Explicit
Public Cursor As Long
Sub WriteLine(ParamArray arr())
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        Me.Cells(Cursor, i + 1).Value = arr(i)
    Next
    Cursor = Cursor + 1
End Sub
Sub Init()
    Cursor = 2
End Sub

標準モジュールのコード

Option Explicit
Const HEADER = 5
Enum Col
    Code = 1
    Workload = 9
    January = 10
    FirstWeek = 22
    Sunday = 26
    Staffs = 33
End Enum
Function WeekNumberByDayOfTheWeek(d As Date) As Long
    Dim ret As Long
    Dim target As Long: target = Weekday(d)
    Dim i As Date
    For i = DateSerial(Year(d), Month(d), 1) To d
        If Weekday(i) = target Then ret = ret + 1
    Next
    If ret > 4 Then ret = 4 '5週目以降は4週目と見做す。
    WeekNumberByDayOfTheWeek = ret
End Function

Sub AggregateStaffWorkloadsForEachDay()
    OutputSheet.Init
    Dim d As Date
    For d = #1/1/2019# To #12/31/2019#
        Dim i
        For i = HEADER + 1 To TaskSheet.Cells(Rows.Count, Col.Code).End(xlUp).Row
            Dim AnnualWorkload: AnnualWorkload = TaskSheet.Cells(i, Col.Workload).Value
            Dim RatioOfMonth: RatioOfMonth = TaskSheet.Cells(i, Col.January + Month(d) - 1).Value
            Dim RatioOfWeek: RatioOfWeek = TaskSheet.Cells(i, Col.FirstWeek + WeekNumberByDayOfTheWeek(d) - 1).Value
            Dim RatioOfWeekday: RatioOfWeekday = TaskSheet.Cells(i, Col.Sunday + Weekday(d) - 1).Value
            Dim staffWorkloads(1 To 3)
            Dim j
            For j = 1 To 3
                staffWorkloads(j) = staffWorkloads(j) + _
                    AnnualWorkload * RatioOfMonth * RatioOfWeek * RatioOfWeekday _
                    * TaskSheet.Cells(i, Col.Staffs + j - 1).Value
            Next
        Next
        If Weekday(d) <> 1 And Weekday(d) <> 7 Then
            OutputSheet.WriteLine d, staffWorkloads(1), staffWorkloads(2), staffWorkloads(3)
        End If
        Dim k As Long
        For k = 1 To 3
            staffWorkloads(k) = 0
        Next
    Next
    MsgBox "Completed"
End Sub

あとはAggregateStaffWorkloadsForEachDayを実行するとOutputSheetに出力されるので、グラフ化するだけ。

手抜き免責事項

• スタッフを3名決め打ちでハードコードしている。

汎用化を考えてるけど、まずは動くところまでこぎつけたかったので雑に作った。
(それくらい直してから記事にすればと言われそうだけど、とりあえず動いた興奮が冷めないうちに記事化してしまわないと、執筆が面倒くさくなる。)

• OutputSheetのヘッダーは手入力しないと入らない。

• 表の構成を記事で説明してない件について

説明が難しいのでGithubでブックごと公開してしまった方が速いんだろうけど、やり方を忘れて調べるのが面倒。。
(とりいそぎ、ヘッダのセル位置だけ公開しておくので再現したい方は頑張ってください。)

A5    Code
B5    Category
C5    Task Name
D5    Description
E5    Cycle
F5    Workload per Cycle (Unit: Minutes)
G5    Monthly Occasion (Unit: Times)
H5    Monthly Workload (Unit: Hours)
I5    Annualy Workload (Unit: Hours)
J5    Jan
K5    Feb
L5    Mar
M5    Apr
N5    May
O5    Jun
P5    Jul
Q5    Aug
R5    Sep
S5    Oct
T5    Nov
U5    Dec
V5    1st Week
W5    2nd Week
X5    3rd Week
Y5    4th/5th Week
Z5    Sun
AA5    Mon
AB5    Tue
AC5    Wed
AD5    Thu
AE5    Fri
AF5    Sat
AG5    Staff A
AH5    Staff B
AI5    Staff C

おわりに

私がブログ記事のタイトルに「アイデア」と付けるときは大抵、未完成品である。
VBA使用者ならアイデアを取得して応用できるだろうと思って、熱意があるうちにサクッと公開してしまう方針なのでどうかご理解いただきたい。
(キチンと完成にこぎつけてから公開しようと思ってると、そのうち熱が冷めてしまってお蔵入りになるので。)