ブックBのデータを検索するためのブックAを作成する

はじめに

　「Excel VBAを使って、ブックAから別のブックBのデータを取り出したい」という要望がありましたので、それを書いていこうと思います。

　今回、完成形をそのままお出しするのではなく、開発工程も含めたリアルタイム的な記述にしたいと思いました。
　いきなり完成したコードを書くのはよほどの天才じゃない限りできません。普通はステップバイステップ、一歩ずつデバッグしながら書いていくことでしょう。
　その工程を含めて記述することで、ご覧になっている方々が開発する時の参考になるかなと思った次第です。
　最終的なコードは最後にまとめておきますので、手っ取り早く知りたい方はそちらをご参照下さい。

要件定義的なところ

　まずは「何を作るのか」ということをざっくりでいいので決めていきましょう。
　次のようなデータが存在するとして、これを別のブックから特定のデータだけ引っ張りたい、という要望でした。
　そういう機能を作っていきます。

データ内容

データの特徴

• シートごとに一か月単位でデータが格納されている
• シート名にはデータが存在する日付が設定されていて、日付型に変換できる文字で構成されている
• データが存在しない無関係なシートも存在する

検索機能

• 検索するのは、製品のキーワードと、データ日付のFromとToという範囲
• 製品名のキーワードが含まれていたら該当のデータとする
• 検索する機能を持つブックとデータが存在するブックは同じフォルダに存在する

　以降データを取り出す検索機能を持つブックのことを"ブックA"、データが存在するブックのことを"ブックB"とすることにします。

データを参照するところまで

　まずはブックAからブックBを開いて、検索の対象の行がヒットするところまで書いてみます。
　説明はコード中のコメントにて行っていきます。

BookA.xlsm

Const TARGET_BOOK_NAME  As String = "BookB.xlsx"    ' 対象のブック名
Const ID_COLUMN_NUM     As Long = 1                 ' IDが存在する列の値を指定
Const PRODUCT_NAME_COLUMN_NUM As Long = 2           ' 製品名が存在する列の値を指定

Sub SearchBook(keyWord As String, fromDate As Date, toDate As Date)
    ' 使用する変数を定義
    Dim book        As Workbook ' ブックB用のオブジェクト
    Dim curSheet    As Variant  ' 現在参照しているシート
    Dim curRowNum   As Long     ' 現在参照している行の数
    Dim tmpDate     As Date     ' 一時的な日付型変数
    Dim tmpStr      As String   ' 一時的な文字型変数
    
    ' 同じフォルダに入っているBookBを開く
    Set book = Workbooks.Open(ThisWorkbook.Path & "\" & TARGET_BOOK_NAME)
    
    ' 全シートごとに繰り返す
    For Each curSheet In book.Sheets
        ' シートの名前が日付型として変換可能ならデータが存在するシートと判定する
        If IsDate(curSheet.Name) Then
            ' シートの名前を日付型に変換する
            tmpDate = CDate(curSheet.Name)
            ' 検索範囲に入っているか判定する
            If fromDate <= tmpDate And tmpDate <= toDate Then
                With curSheet   ' ここから特定のシートの話なので with を使って限定する
                    curRowNum = 2  ' 一行目は項目行で、二行目からデータなので2からスタート
                    ' データが存在しない行まで繰り返す
                    Do While IsEmpty(.Cells(curRowNum, ID_COLUMN_NUM)) = False ' IDは必ず値が入っている項目なので判定に使用
                        tmpStr = .Cells(curRowNum, PRODUCT_NAME_COLUMN_NUM).Text    ' 製品の値を取得する
                        ' キーワードを含んでいる製品かを判定
                        If InStr(tmpStr, keyWord) Then
                            Debug.Print "とりあえずここまで行けるかな"
                        End If
                        curRowNum = curRowNum + 1 ' 次の行へ
                    Loop
                End With
            End If
        End If
    Next curSheet
End Sub

　Debug.Print "とりあえずここまで行けるかな" まで行けるかどうかコードをデバッグしてみましょう。
　テスト用の実行コードとして次の関数を用意します。

テスト的に実行する関数

Sub TestRun()
    Dim fromDate As Date
    Dim toDate As Date
   
    fromDate = CDate("2020/4")
    toDate = CDate("2020/5")
    
    Call SearchBook("あああ", fromDate, toDate)

End Sub

デバッグ開始

　F8を押して実行開始します。

　F8を押し続けたり、F9でブレークポイントを設定したりして、コードの実行を見ていきます。

　イミディエイト ウィンドウに記述されることが確認できました。Debug.Print まで辿り着けたようです。
　ウォッチウィンドウを使って、tmpSrtの中身を見てみると、製品の値もきちんと取れていますね。

データを取得するところまで

　次は該当データを持ってくるところまで書いていきます。
　データを「戻り値」として返す必要があるため、 SearchBookは Sub ではなく、Function に切り替えます。

データを検索して取得する関数

Const TARGET_BOOK_NAME  As String = "BookB.xlsx"    ' 対象のブック名
Const ID_COLUMN_NUM     As Long = 1                 ' IDが存在する列の値を指定
Const COLUMN_MAX_NUM    As Long = 4                 ' ブックBのデータの最大列数。D列までなので4
Const PRODUCT_NAME_COLUMN_NUM As Long = 2           ' 製品名が存在する列の値を指定

Function SearchBook(keyWord As String, fromDate As Date, toDate As Date) As Variant
    ' 使用する変数を定義
    Dim book        As Workbook ' ブックB用のオブジェクト
    Dim curSheet    As Variant  ' 現在参照しているシート
    Dim curRowNum   As Long     ' 現在参照している行の数
    Dim tmpDate     As Date     ' 一時的な日付型変数
    Dim tmpStr      As String   ' 一時的な文字型変数
    Dim twoArray()  As Variant  ' 検索結果を保存する用の二次元配列。様々な型が入るように Variant
    Dim dataCount   As Long     ' データ数
    Dim i           As Long     ' for文カウント用変数
    
    ' データの初期化
    dataCount = 0   ' デフォルト値はゼロなので必要ないけど、コード的な分かりやすいさを意識して。
    
    ' 同じフォルダに入っているブックBを開く
    Set book = Workbooks.Open(ThisWorkbook.Path & "\" & TARGET_BOOK_NAME)

    ' 全シートごとに繰り返す
    For Each curSheet In book.Sheets
        ' シートの名前が日付型として変換可能ならデータが存在するシートと判定する
        If IsDate(curSheet.Name) Then
            ' シートの名前を日付型に変換する
            tmpDate = CDate(curSheet.Name)
            ' 検索範囲に入っているか判定する
            If fromDate <= tmpDate And tmpDate <= toDate Then
                With curSheet   ' ここから特定のシートの話なので with を使って限定する
                    curRowNum = 2  ' 一行目は項目行で、二行目からデータなので2からスタート
                    ' データが存在しない行まで繰り返す
                    Do While IsEmpty(.Cells(curRowNum, ID_COLUMN_NUM)) = False ' IDは必ず値が入っている項目なので判定に使用
                        tmpStr = .Cells(curRowNum, PRODUCT_NAME_COLUMN_NUM).Text    ' 製品の値を取得する
                        ' キーワードを含んでいる製品かを判定
                        If InStr(tmpStr, keyWord) Then
                            ' 必要なデータが存在したということなので、データ数のカウントを+1
                            dataCount = dataCount + 1
                            ' それに合わせて保存用の二次元配列の大きさを、データを保存したまま拡張。
                            ReDim Preserve twoArray(1 To COLUMN_MAX_NUM, 1 To dataCount)
                            ' 同一行の列ごとのデータを保存
                            For i = 1 To COLUMN_MAX_NUM
                                ' ポイント：列と行が入れ替わっている
                                twoArray(i, dataCount) = .Cells(curRowNum, i)
                            Next i
                        End If
                        curRowNum = curRowNum + 1 ' 次の行へ
                    Loop
                End With
            End If
        End If
    Next curSheet

    ' 開いたブックBを閉じる
    book.Close

    ' データが空の場合はそのまま終了
    If dataCount = 0 Then
        Exit Function
    End If
    
    ' Excel関数の転置を呼び出して、行と列を入れ替える
    Dim resultValue As Variant
    resultValue = WorksheetFunction.Transpose(twoArray)
     
    ' データを戻り値としてセットする
    SearchBook = resultValue
        
End Function

　このコードの説明の補足を行います。
　もっとも重要なポイントは、コメントでも記述したように「ポイント：列と行が入れ替わっている」箇所です。検索ヒットしたデータを格納するtwoArray() は、セルの値を保存する時に行と列が入れ替わっています。

twoArray(i, dataCount) = .Cells(curRowNum, i)

　基本的に二次元配列は (行, 列)の関係で記述します。しかしtwoArray()に関しては、(列, 行)の関係で記述されています。コードの可読性が低下するので、twoArray(行, 列)のフォーマットで書いた方がいいに決まっています。何故このようになっているのでしょうか。
　それはVBAの仕様によるものです。
　VBAでは二次元配列、多次元配列の変数において、データを保存したまま大きさを変える場合、一番最後のパラメータしか変更できないという制限あります。

 ' ReDim で再定義。Preserve を付けることでデータ保存したまま再定義するという意味
ReDim Preserve twoArray(1 To COLUMN_MAX_NUM, 1 To dataCount)

　今回の事例では列の数は変わらず、行の数が変更するパターンです。そのため行の方を後ろに持ってくる必要があるのです。

　試しに行と列が入れ替わっていないコードにして実行してみましょう。

twoArrayの行・列の入れ替わりがないコード

' 必要なデータが存在したということなので、データ数のカウントを+1
dataCount = dataCount + 1

' それに合わせて保存用の二次元配列の大きさをデータを保存したまま拡張。
ReDim Preserve twoArray(1 To dataCount, 1 To COLUMN_MAX_NUM)
' 同一行の列ごとのデータを保存
For i = 1 To COLUMN_MAX_NUM
    ' ポイント：列と行は入れ替わっていない
    twoArray(dataCount, i) = .Cells(curRowNum, i)
Next i

　このコードで実行してみると、ReDim Preserve twoArray(1 To dataCount, 1 To COLUMN_MAX_NUM) の二回目の実行時にエラーが発生します。

　再定義による大きさの変更は一番後ろのパラメーターしかできないのに、前の方の大きさを変更しようとしたからです。

　別案として、大きさを変更しなければいいということで、事前に大きさを把握しておくというやり方があります。

1. 先に「検索結果の数」を把握しておく
2. twoArray()の大きさを決定する
3. twoArray()にデータを格納する

　このようにすれば、twoArray(行, 列)という本来の形にすることはできます。
　できますが、それをやると計算量が増えるので今回その方法は採用しません。

　――とはいえ、(列, 行)という状態のままなのはミスの原因になるため修正する必要があります。

　ここで、Excelは表計算ソフトということを思い出しましょう。
　行列計算においては、行と列が入れ替わることが頻繁にあり、これを「転置」といいます。
　当然、Excelは表計算ソフトですからExcel関数として持っています。それを利用して入れ替わった行と列を元に戻します。

    ' Excel関数の転置を呼び出して、行と列を入れ替える
    Dim resultValue As Variant
    resultValue = WorksheetFunction.Transpose(twoArray)

　行と列が入れ替わった状態の変数

　転置を実行して、行と列の関係が元に戻った変数

　テストコードで試してみましょう。

テスト的に実行する関数

Sub TestRun()
    Dim fromDate As Date
    Dim toDate As Date
    Dim result  As Variant
    
    fromDate = CDate("2020/4")
    toDate = CDate("2020/5")
    
    result = SearchBook("あああ", fromDate, toDate)
    If IsEmpty(result) Then
        Debug.Print "検索結果はありませんでした"
    Else
        Debug.Print "検索にヒットしました"
    End If
End Sub

　確認すると問題なく動いているようです。

余談:簡単にできるならExcel関数を使おう

　VBAは出来ることの自由度は高いのですが、計算手法（アルゴリズム）を自分で構築する必要があります。
　「自分で構築する」というのは勉強になる一方、ミスの原因にもなりますし、面倒くさいです。
　Excel関数で簡単にできるならば、そちらを使った方がいいでしょう。
　基本的に「計算する」ことに関しては Excel関数を使うといいと思います。並び替え（ソート）も自分でクイックソートを構築するよりも、Excel関数を利用した方がはるかに簡単で高速です。

（参考）
計算式とVBAではどっちが良い！？
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_100.html

配列のデータを並べ替える
https://www.moug.net/tech/exvba/0100052.html

取得したデータを表示するところまで

　取得したデータは表示しないと意味がありません。
　検索するためのキーワード入力欄も作る必要があります。
　今回は「検索シート」というシートを作成して、次のようなインターフェースにしてみました。

検索ボタンの作り方

　開発タブの「挿入」からボタンを選択します。今回は「ActiveXコントロール」の方のボタンを使ってみます。

　開発タブの「デザインモード」をONにして、ボタンを右クリックするとプロパティが呼び出せます。

　ボタンの設定は次の通りです。名前は「SearchButton」にしました。キャプションは「検索」です。

ちょっとした技

　「デザインモード」がONの状態で、作成したボタンをダブルクリックすると、そのボタンを押した場合の関数が自動生成されます。

　ここにボタンを押したときの動作を書いていきましょう。
　実行する際は「デザインモード」をOFFにすることを忘れずに。

コードを記述

　それでは入力欄から情報を取得して、所定の位置に貼り付けるコードを書いていきます。
　とりあえず出力結果を見たいということもあって入力チェックは省いています。（From の値が To よりも未来だった場合はエラーを出すなど）

　なお、これは標準モジュールではなく、ワークシート「検索シート」に記述するコードになります。

実行するシートに記述する

Const keywordCellName   As String = "A2"    ' 検索キーワード入力セル位置
Const fromCellName      As String = "B2"    ' 検索from入力セル位置
Const toCellName        As String = "C2"    ' 検索to入力セル位置

Private Sub SearchButton_Click()    
    ' 各検索パラメーター
    Dim keyWord     As String
    Dim fromText    As String
    Dim toText      As String
    
    ' セル入力時は文字型なので、それを日付型に変換するためのもの
    Dim fromDate    As Date
    Dim toDate      As Date
    
    ' 検索結果を格納する
    Dim result      As Variant
    
    ' 入力セル位置から値を取得する
    keyWord = Range(keywordCellName).Text
    fromText = Range(fromCellName).Text
    toText = Range(toCellName).Text
    
    ' Date型に変換する
    fromDate = CDate(fromText)
    toDate = CDate(toText)
    
    ' 検索実行する
    result = SearchBook(keyWord, fromDate, toDate)
    
    ' 結果を出力する
    Call WriteResult(result)    
End Sub

' 結果を出力する関数
Private Sub WriteResult(result As Variant)
    Dim startRowNum     As Long ' 開始する行数
    Dim startColumnNum  As Long ' 開始する列数
    Dim endRowNum       As Long ' 最後の行数
    Dim maxColumnNum    As Long ' 最大列数
    
    ' 列ごと削除する（面倒なので）
    Columns("F:I").Delete Shift:=xlToLeft
    
    ' 項目名をセットする
    Range("F1") = "ID"
    Range("G1") = "製品"
    Range("H1") = "日付"
    Range("I1") = "個数"
    
    If IsEmpty(result) Then
        MsgBox "検索結果はありませんでした", vbExclamation
        Exit Sub    ' 関数を終了
    End If
    
    startRowNum = 2         ' 1行目がヘッダーでデータは2行目のため
    startColumnNum = 6      ' F列から記述するため。そしてFは6番目
    endRowNum = startRowNum + UBound(result, 1) - 1         ' 開始行数 + データ数 - 1が最後の行数
    maxColumnNum = startColumnNum + UBound(result, 2) - 1   ' 開始列数 + 列数 - 1が最後の列数
    
    ' データをシートに貼り付ける形で与える
    Range(Cells(startRowNum, startColumnNum), Cells(endRowNum, maxColumnNum)) = result
    
    ' セルの大きさを自動でフィットさせる
    Columns("F:I").EntireColumn.AutoFit
End Sub

　コードを記述するのは標準モジュールではなく、ワークシートの「検索シート」に。

　それでは実行してみましょう。

検索がヒットするパターン

検索がヒットしないパターン

　これで一覧の入力、検索、表示という一連の動作が可能になりました。

追加の要件

　機能の追加を要望されました。
　「検索するのにいちいちボタンを押すのは面倒」「値を入力した時に自動で出力してほしい」「INDIRECT関数みたいなイメージで」
　なるほど。確かにサジェスト機能みたいに、入力したら自動で表示されるというのが最近のトレンドなのかもしれません。
　それでは実装していきましょう。

自動検索機能を実装する

　ワークシート中のセルが変更された時のイベントとしてWorksheet_Change()があります。これを使って入力されたことに気づけるようにします。
　Worksheet_Change()は下記のコード箇所からのコピペでも構いませんが、次のように自動で生成することもできます。

左上のところで、Worksheet を選択：

右上のところで、Change を選択：

自動生成されたWorksheet_Change()：

　試しにWorksheet_Change()を使ってみましょう。
　次のコードで、変更したセルのアドレスがイミディエイト ウィンドウに表示されます。

Worksheet_Changeを使ってみる

Private Sub Worksheet_Change(ByVal Target As Range)
    Debug.Print Target.Address  ' 変更したセルの場所を表示する
End Sub

変更したセルの箇所が表示されるのを確認：

自動検索機能の実装手法

　もっとも簡単なやり方は 変更されたセル(Target) が検索パラメータのアドレスならば、検索を実行するというやり方です。
　前回確認したように Target.Address の中身は、『＄』が付いた絶対参照のアドレスなので、比較可能なように定数の方にも『＄』を付けておきましょう。また定数の名前も keywordCellName よりも keywordCellAddress の方が適していますね。修正しておきましょう。

前回の定数の箇所

Const keywordCellName   As String = "A2"    ' 検索キーワード入力セル位置
Const fromCellName      As String = "B2"    ' 検索from入力セル位置
Const toCellName        As String = "C2"    ' 検索to入力セル位置

修正した定数の箇所

Const keywordCellAddress   As String = "$A$2"    ' 検索キーワード入力セル位置
Const fromCellAddress      As String = "$B$2"    ' 検索from入力セル位置
Const toCellAddress        As String = "$C$2"    ' 検索to入力セル位置

　変数を修正する際は手入力で行うとミスが発生しやすいので、置換機能を使って行います。

検索入力欄が変更されたら検索実行（仮）

Const keywordCellAddress   As String = "$A$2"    ' 検索キーワード入力セル位置
Const fromCellAddress      As String = "$B$2"    ' 検索from入力セル位置
Const toCellAddress        As String = "$C$2"    ' 検索to入力セル位置

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = keywordCellAddress _
        Or Target.Address = fromCellAddress _
        Or Target.Address = toCellAddress Then
        
        Call SearchButton_Click    ' 検索実行ボタンをクリック
    End If
End Sub

　さて、これで検索自動実行は出来そうですが、セル入力即検索実行では不必要な検索が頻発します。検索を実行する前に、その入力値が正しいものなのかという「入力チェック機能」を作る必要があります。

今回の場合、次のような確認が必要です。

• 必須項目確認：検索パラメーターが入力されているか
• 形式確認：日付入力箇所が日付の形式になっているか
• 整合性確認：FromがToよりも未来になっていないか

　入力チェックには他にも種類があるので抑えておいた方がいいでしょう。

（参考）IT用語辞典 e-Words『データチェック』
http://e-words.jp/w/データチェック.html

　入力エラーメッセージは、Excelのステータスバーに表示することとします。
　メッセージボックスでの通知だとうざいったらないですからね。
　また、検索実行時にちらつくのもうざいので「Application.ScreenUpdating」を使って画面更新の一時停止を行います。

入力確認を行う

' 入力確認を行い、問題なければTrueを、問題が発生していたらFalseを返す
' 問題が発生していた時のメッセージはステータスバーに表示する
Private Function VerifyInputValue(keyWord As String, fromText As String, toText As String) As Boolean
    ' ステータスバーをリセットする
    Application.StatusBar = False
    
    ' 戻り値を初期設定
    VerifyInputValue = False
    
    If keyWord = "" Then
        Application.StatusBar = "検索キーワードが空です"
        Exit Function
    End If
    If fromText = "" Then
        Application.StatusBar = "Fromが空です"
        Exit Function
    End If
    If toText = "" Then
        Application.StatusBar = "Toが空です"
        Exit Function
    End If
    
    If IsDate(fromText) = False Then
        Application.StatusBar = "Fromが日付型ではありません"
        Exit Function
    End If
    
    If IsDate(toText) = False Then
        Application.StatusBar = "Toが日付型ではありません"
        Exit Function
    End If
        
    If CDate(fromText) > CDate(toText) Then
        Application.StatusBar = "FromがToよりも未来に設定されています"
        Exit Function
    End If
        
    ' 全部のチェックが問題ないなら 戻り値をTrueにする
    VerifyInputValue = True
End Function

入力確認を行う

Private Sub SearchButton_Click()
    ' 各検索パラメーター
    Dim keyWord     As String
    Dim fromText    As String
    Dim toText      As String
    
    ' セル入力時は文字型なので、それを日付型に変換するためのもの
    Dim fromDate    As Date
    Dim toDate      As Date
    
    ' 検索結果を格納する
    Dim result      As Variant
    ' 表示更新の停止
    Application.ScreenUpdating = False

    ' 入力セル位置から値を取得する
    keyWord = Range(keywordCellAddress).Text
    fromText = Range(fromCellAddress).Text
    toText = Range(toCellAddress).Text
    
    ' 入力確認
    If VerifyInputValue(keyWord, fromText, toText) = False Then
        ' 問題が発生していたら終了
        Exit Sub
    End If
    
    ' Date型に変換する
    fromDate = CDate(fromText)
    toDate = CDate(toText)
    
    ' 検索実行する
    result = SearchBook(keyWord, fromDate, toDate)
    
    ' 結果を出力する
    Call WriteResult(result)

    ' 表示更新の再開
    Application.ScreenUpdating = True
End Sub

　入力エラーの場合は、次のようになります。（"FromがToよりも未来に設定されています"　が表示されている）

　検索ボタンを削除するか迷うところですが、自動検索が上手く動かなかった場合の手段として残して置くこととします。（検索機能が動かなかったら手動で実行して、という）

課題点

　これで一連の機能が出来上がりましたが、現時点では拡張性にやや難があると考えています。データ収集を二次元配列で行っているため、データの検索機能を拡張しづらいのです。たとえば個数で検索したいとか。
　項目数が少ない場合は力業と何とかなるかもしれませんが、これが50個あった場合には「3番目の列は個数の項目であってた？43番目の列は何の値だっけ？」と混乱すること必須です。
　これにつきましては拙投稿のこちらを参考にしてデータを構造化してみてください。

Excelシート上のデータ構造のまま、クラスとCollectionでVBA上のデータとして扱う
https://qiita.com/saeki4n/items/12f3ccbafbbd50bba616

　以上で、開発の一連の工程を記述してみました。
　気になることや質問などがございましたらお気軽にコメントくださいませ。

作成したコードまとめ

シートに記述するコード

Const keywordCellAddress   As String = "$A$2"    ' 検索キーワード入力セル位置
Const fromCellAddress      As String = "$B$2"    ' 検索from入力セル位置
Const toCellAddress        As String = "$C$2"    ' 検索to入力セル位置

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = keywordCellAddress _
        Or Target.Address = fromCellAddress _
        Or Target.Address = toCellAddress Then
        
        Call SearchButton_Click    ' 検索実行ボタンをクリック
    End If
End Sub


' 入力確認を行い、問題なければTrueを、問題が発生していたらFalseを返す
' 問題が発生していた時のメッセージはステータスバーに表示する
Private Function VerifyInputValue(keyWord As String, fromText As String, toText As String) As Boolean
    ' ステータスバーをリセットする
    Application.StatusBar = False
    
    ' 戻り値を初期設定
    VerifyInputValue = False
    
    If keyWord = "" Then
        Application.StatusBar = "検索キーワードが空です"
        Exit Function
    End If
    If fromText = "" Then
        Application.StatusBar = "Fromが空です"
        Exit Function
    End If
    If toText = "" Then
        Application.StatusBar = "Toが空です"
        Exit Function
    End If
    
    If IsDate(fromText) = False Then
        Application.StatusBar = "Fromが日付型ではありません"
        Exit Function
    End If
    
    If IsDate(toText) = False Then
        Application.StatusBar = "Toが日付型ではありません"
        Exit Function
    End If
        
    If CDate(fromText) > CDate(toText) Then
        Application.StatusBar = "FromがToよりも未来に設定されています"
        Exit Function
    End If
        
    ' 全部のチェックが問題ないなら 戻り値をTrueにする
    VerifyInputValue = True
End Function

Private Sub SearchButton_Click()
    ' 各検索パラメーター
    Dim keyWord     As String
    Dim fromText    As String
    Dim toText      As String
    
    ' セル入力時は文字型なので、それを日付型に変換するためのもの
    Dim fromDate    As Date
    Dim toDate      As Date
    
    ' 検索結果を格納する
    Dim result      As Variant
    ' 表示更新の停止
    Application.ScreenUpdating = False

    ' 入力セル位置から値を取得する
    keyWord = Range(keywordCellAddress).Text
    fromText = Range(fromCellAddress).Text
    toText = Range(toCellAddress).Text
    
    ' 入力確認
    If VerifyInputValue(keyWord, fromText, toText) = False Then
        ' 問題が発生していたら終了
        Exit Sub
    End If
    
    ' Date型に変換する
    fromDate = CDate(fromText)
    toDate = CDate(toText)
    
    ' 検索実行する
    result = SearchBook(keyWord, fromDate, toDate)
    
    ' 結果を出力する
    Call WriteResult(result)

    ' 表示更新の再開
    Application.ScreenUpdating = True
End Sub

' 結果を出力する関数
Private Sub WriteResult(result As Variant)
    Dim startRowNum     As Long ' 開始する行数
    Dim startColumnNum  As Long ' 開始する列数
    Dim endRowNum       As Long ' 最後の行数
    Dim maxColumnNum    As Long ' 最大列数
    
    ' 列ごと削除する（面倒なので）
    Columns("F:I").Delete Shift:=xlToLeft
    
    ' 項目名をセットする
    Range("F1") = "ID"
    Range("G1") = "製品"
    Range("H1") = "日付"
    Range("I1") = "個数"
    
    If IsEmpty(result) Then
        MsgBox "検索結果はありませんでした", vbExclamation
        Exit Sub    ' 関数を終了
    End If
    
    startRowNum = 2         ' 1行目がヘッダーでデータは2行目のため
    startColumnNum = 6      ' F列から記述するため。そしてFは6番目
    endRowNum = startRowNum + UBound(result, 1) - 1         ' 開始行数 + データ数 - 1が最後の行数
    maxColumnNum = startColumnNum + UBound(result, 2) - 1   ' 開始列数 + 列数 - 1が最後の列数
    
    ' データをシートに貼り付ける形で与える
    Range(Cells(startRowNum, startColumnNum), Cells(endRowNum, maxColumnNum)) = result
    
    ' セルの大きさを自動でフィットさせる
    Columns("F:I").EntireColumn.AutoFit
End Sub

モジュールとして記述するコード

Const TARGET_BOOK_NAME  As String = "BookB.xlsx"    ' 対象のブック名
Const ID_COLUMN_NUM     As Long = 1                 ' IDが存在する列の値を指定
Const COLUMN_MAX_NUM    As Long = 4                 ' ブックBのデータの最大列数。D列までなので4
Const PRODUCT_NAME_COLUMN_NUM As Long = 2           ' 製品名が存在する列の値を指定

Function SearchBook(keyWord As String, fromDate As Date, toDate As Date) As Variant
    ' 使用する変数を定義
    Dim book        As Workbook ' ブックB用のオブジェクト
    Dim curSheet    As Variant  ' 現在参照しているシート
    Dim curRowNum   As Long     ' 現在参照している行の数
    Dim tmpDate     As Date     ' 一時的な日付型変数
    Dim tmpStr      As String   ' 一時的な文字型変数
    Dim twoArray()  As Variant  ' 検索結果を保存する用の二次元配列。様々な型が入るように Variant
    Dim dataCount   As Long     ' データ数
    Dim i           As Long     ' for文カウント用変数
    
    ' データの初期化
    dataCount = 0   ' デフォルト値はゼロなので必要ないけど、コード的な分かりやすいさを意識して。
    
    ' 同じフォルダに入っているブックBを開く
    Set book = Workbooks.Open(ThisWorkbook.Path & "\" & TARGET_BOOK_NAME)

    ' 全シートごとに繰り返す
    For Each curSheet In book.Sheets
        ' シートの名前が日付型として変換可能ならデータが存在するシートと判定する
        If IsDate(curSheet.Name) Then
            ' シートの名前を日付型に変換する
            tmpDate = CDate(curSheet.Name)
            ' 検索範囲に入っているか判定する
            If fromDate <= tmpDate And tmpDate <= toDate Then
                With curSheet   ' ここから特定のシートの話なので with を使って限定する
                    curRowNum = 2  ' 一行目は項目行で、二行目からデータなので2からスタート
                    ' データが存在しない行まで繰り返す
                    Do While IsEmpty(.Cells(curRowNum, ID_COLUMN_NUM)) = False ' IDは必ず値が入っている項目なので判定に使用
                        tmpStr = .Cells(curRowNum, PRODUCT_NAME_COLUMN_NUM).Text    ' 製品の値を取得する
                        ' キーワードを含んでいる製品かを判定
                        If InStr(tmpStr, keyWord) Then
                            ' 必要なデータが存在したということなので、データ数のカウントを+1
                            dataCount = dataCount + 1
                            ' それに合わせて保存用の二次元配列の大きさをデータを保存したまま拡張。
                            ReDim Preserve twoArray(1 To COLUMN_MAX_NUM, 1 To dataCount)
                            ' 同一行の列ごとのデータを保存
                            For i = 1 To COLUMN_MAX_NUM
                                ' ポイント：列と行が入れ替わっている
                                twoArray(i, dataCount) = .Cells(curRowNum, i)
                            Next i
                        End If
                        curRowNum = curRowNum + 1 ' 次の行へ
                    Loop
                End With
            End If
        End If
    Next curSheet

    ' 開いたブックBを閉じる
    book.Close

    ' データが空の場合はそのまま終了
    If dataCount = 0 Then
        Exit Function
    End If
    
    ' Excel関数の転置を呼び出して、行と列を入れ替える
    Dim resultValue As Variant
    resultValue = WorksheetFunction.Transpose(twoArray)
     
    ' データを戻り値としてセットする
    SearchBook = resultValue
End Function