マクロVBA練習問題23

問題

エクセルの神髄さんの練習問題23(総合練習5)を解いた。

練習問題23（総合練習5）｜VBA練習問題

解答

メインプロシージャ

Sub 練習問題23()
    
    '検索ワード設定
    Dim keyDate As String: keyDate = CStr(Sheet23_1.Range("A2").Value)
    Dim keyName As String: keyName = Sheet23_1.Range("B2").Value
    
    '検索範囲設定
    Dim dataRng As Range: Set dataRng = Sheet23_2.Range("A1").CurrentRegion
    
    '検索処理
    Dim Output As Variant
    Output = Get_FilterData(dataRng, keyDate, keyName)
    
    '前回の検索結果を消去
    Sheet23_1.Range("A4").CurrentRegion.Offset(1, 0).ClearContents
    
    '検索結果を貼付
    If IsEmpty(Output) Then
        MsgBox "キーワードが設定されていませんので中断します", vbExclamation, "設定エラー"
    ElseIf Output(1, 1) = "" Then
        MsgBox "キーワードに一致するデータが見つかりませんでした。", vbExclamation, "検索結果"
    Else
        Sheet23_1.Range("A5").Resize(UBound(Output, 1), UBound(Output, 2)).Value = Output
    End If
    
End Sub

データ抽出ファンクション

'**
'* 検索対象のデータ範囲内でキーワードに一致したデータを二次元配列に格納して返す関数
'* 引数１：inRng   {Range型}   検索対象のデータ範囲を指定
'* 引数２：keyDate {String型}  日付の検索キーワードを指定
'* 引数３：keyName {String型}  名前の検索キーワードを指定
'* 戻り値：        {Variant型} キーワードに一致したデータ（二次元配列）を返す
'**
Private Function Get_FilterData(ByVal inRng As Range, _
                              ByVal keyDate As String, _
                              ByVal keyName As String) As Variant
    '設定
    Dim StartRow As Long: StartRow = 2
    Dim EndRow As Long: EndRow = inRng.Rows.Count
    
    Dim I As Long, J As Long, Count As Long
    ReDim Output(1 To inRng.Columns.Count, 1 To 1) As Variant
    
    For I = StartRow To EndRow
        Dim Flag As Boolean: Flag = False
        
        'キーワードが両方空欄の場合はFunctionを抜ける
        If keyDate = "" And keyName = "" Then Exit Function
        
        'キーワードが両方設定されている場合はAND検索とする
        If keyDate <> "" And keyName <> "" Then
            If InStr(CStr(inRng.Cells(I, "A").Value), keyDate) > 0 _
                And InStr(inRng.Cells(I, "B").Value, keyName) > 0 Then Flag = True
        Else
            '日付のみがキーワードに設定されている場合
            If keyDate <> "" Then
                If InStr(CStr(inRng.Cells(I, "A").Value), keyDate) > 0 Then Flag = True
            End If
            '名前のみがキーワードに設定されている場合
            If keyName <> "" Then
                If InStr(inRng.Cells(I, "B").Value, keyName) > 0 Then Flag = True
            End If
        End If
        
        'キーワードに一致したデータがあれば配列に格納
        If Flag Then
            Count = Count + 1
            ReDim Preserve Output(1 To inRng.Columns.Count, 1 To Count) As Variant
            Output(1, Count) = inRng.Cells(I, "A").Value
            Output(2, Count) = inRng.Cells(I, "B").Value
            Output(3, Count) = inRng.Cells(I, "C").Value
        End If
    Next I
    
    Get_FilterData = Transpose_Array2D(Output)
    
End Function

検索条件の設定が結構複雑になってしまった。
もう少し単純に書ける？

転置ファンクション

'**
'* 二次元配列を転置する関数
'* 引数１：Array2D {Variant型} 転置処理したい二次元配列を指定
'* 戻り値：        {Variant型} 転置処理後の二次元配列
'**
Private Function Transpose_Array2D(ByVal Array2D As Variant) As Variant
    
    '処理
    Dim RL As Long: RL = LBound(Array2D, 2)
    Dim RU As Long: RU = UBound(Array2D, 2)
    Dim CL As Long: CL = LBound(Array2D, 1)
    Dim CU As Long: CU = UBound(Array2D, 1)
    
    ReDim outArr(1 To RU - RL + 1, 1 To CU - CL + 1) As Variant
    
    Dim I As Long, J As Long
    Dim counterR As Long: counterR = 0
    Dim counterC As Long
    For I = RL To RU
        counterR = counterR + 1
        counterC = 0
        For J = CL To CU
            counterC = counterC + 1
            outArr(counterR, counterC) = Array2D(J, I)
        Next J
    Next I
    
    '出力
    Transpose_Array2D = outArr
    
End Function

WorksheetFunctionのTransposeを使うと、検索結果が1件の場合に二次元配列から一次元配列に変換されてしまうので別途関数を作りました。