実践！Excelマクロ　～検索フォームの活用で入力スピード最大UPを目指す！～

前回に引き続き現金出納帳を例に、「実践！Excelマクロ」をアップします。
今回は科目など、よく繰り返して利用する項目を検索フォームから呼び出して入力を楽に、スピードアップするためのマクロを作成してみましょう！

※検索関連のエントリー「Excelのシートを複数条件で検索するVBAサンプルコード（ADO）」もご参考下さい。

動作イメージは以下の通りです。

今回のマクロ化に必要な工程は以下のステップです。

1.科目マスタ用のsheetを作成します

検索フォームに表示するマスタ用のシートを作成しましょう。今回は[シート名]を仮に[科目マスタ]として作成します。

2.検索用フォームを作成します

VBE(Visual Basic Editor)を[Alt]+[F11]で起動し、[挿入]　→　[ユーザー フォーム(U)]　でフォームを作成します。
今回の事例ではフォーム名や各コントロール名を以下の通り作成しています。

3.ダブルクリックで検索用フォームを表示させます

科目セルをダブルクリックした際の動作を設定しましょう。
ダブルクリックした際、先ほど作成した検索フォームを表示するにはSheet1（出納帳）に以下のVBAコードを設定します。

'*****************************************************
'セルをダブルクリックした時の処理
'*****************************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim wLastGyou As Long
    Dim wSheetName As Variant

    'アクティブなシート名を取得
    wSheetName = ActiveSheet.Name

    '最終行番号を取得
    wLastGyou = Worksheets(wSheetName).UsedRange.Rows.Count

    'B5からB列の最終行以外の範囲の場合は処理を実行しない
    If Intersect(Target, Range("B5:B" & wLastGyou - 1)) Is Nothing Then Exit Sub
    Cancel = True

    '検索フォームを表示します。
    frm_Kamoku.Show

End Sub

4.科目マスタSheetから検索フォームのリストボックスに表示する値を取得します

検索フォームを開いた時、リストボックス[lstKamoku]のRowSourceに科目マスタSheetの値をセットします。
VBAコードは以下の通りです。

'*****************************************************
'検索フォームを開いた時の処理
'*****************************************************
Private Sub UserForm_Initialize()
    Dim wLastGyou As Long

    '最終行番号を取得
    wLastGyou = Worksheets("科目マスタ").UsedRange.Rows.Count

    'リストボックスに「科目マスタ」のリストをセット
    With lstKamoku

        '列の指定：1列とする
        .ColumnCount = 1

        '見出しの設定：無し
        .ColumnHeads = False

        'リストボックスの値にセルA2からA最終行までセット
        .RowSource = "科目マスタ!A2:A" & wLastGyou

    End With

End Sub

5.検索フォームに科目絞り込み機能を実装します

検索用テキストボックスに含まれた文字をリストボックスに絞り込んで表示する機能を作成しましょう。

テキストボックス[txbSerch]の更新後にFindメソッドを使ってリストボックス[lstKamoku]に表示する値を科目マスタSheetから絞り込みます。VBAコードは以下の通りです。

'*****************************************************
'検索用のテキストボックス更新後の処理
'*****************************************************
Private Sub txbSerch_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    Dim Obj As Object
    Dim wAddST As Variant
    Dim wAddress As Variant
    Dim wKamoku As Variant

    With Worksheets("科目マスタ")

        'テキストボックスの値が含まれるセルを検索
        Set Obj = .Cells.Find( _
                            What:=txbSerch.Value, _
                            LookIn:=xlValues, _
                            lookat:=xlPart, _
                            MatchByte:=False)

        '検索対象がない場合はメッセージを表示
        If Obj Is Nothing Then
            MsgBox "対象科目は存在しません。", _
                            vbOKOnly + vbInformation, "検索"
        Else
            'リストボックスをクリア
            lstKamoku.RowSource = ""

            '検索にヒットした先頭のセルのアドレスをセット
            wAddST = Obj.Address

            '検索の繰り返し処理
            Do
                '検索にヒットしたセルのアドレスをセット
                wAddress = Obj.Address

                '検索にヒットしたセルの値を取得
                wKamoku = .Range(wAddress).Value

                'リストボックスに追加
                lstKamoku.AddItem wKamoku

                '次の検索を行う
                Set Obj = .Cells.FindNext(Obj)

                '最初にヒットしたアドレスと同じ場合は処理を終了
                If Obj.Address = wAddST Then Exit Do
            Loop

        End If

    End With

End Sub

6.リストボックスのダブルクリックで出納帳Sheetに値を反映する

検索フォームのリストボックスをダブルクリックした際、出納帳Sheetのアクティブなセルに値をセットするようにします。
リストボックス[lstKamoku]のダブルクリック時に以下のVBAコードをセットします。

'*****************************************************
'リストボックスをダブルクリックした時の処理
'*****************************************************
Private Sub lstKamoku_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim wSheetName As Variant

    'アクティブなシート名を取得
    wSheetName = ActiveSheet.Name

    'アクティブなセルにリストボックスの値をセット
    With Worksheets(wSheetName)
        .Cells(ActiveCell.Row, ActiveCell.Column).Value = lstKamoku.List(lstKamoku.ListIndex, 0)
    End With

    'フォームを終了する
    Unload Me

End Sub

検索関連エントリー

現金出納帳関連エントリー

以上、今回はExcelで検索フォームを利用する為のVBAマクロでした。