Excel VBAでスピルする新関数「FILTER」を使う方法

'ワークシート関数のFILTERを使ってみる
Sub wsFuncFILTER_Sample()
    Dim r   '戻り値の動的配列は２次元配列
    Dim sr As Long      '開始行
    Dim er As Long      '最終行
    Dim rng As Range    '元データのセル選択用
    Dim exprng As Range   '書き込みセル選択用
    Dim tgcol As String   '検索列セル範囲アドレス
    Dim param As String   'Evaluateに渡す文字列
    
    'Application.InputBoxで対象表を選択させる
    On Error Resume Next
    Set rng = Application.InputBox( _
            Prompt:="表の先頭（左上）セルを１つ選択してください", _
            Title:="セル選択", Type:=8)
    If rng Is Nothing Then On Error GoTo 0: Exit Sub
    '結果を書き出すセル範囲の左上を選択させる
    Set exprng = Application.InputBox( _
            Prompt:="結果を書き出すセル範囲の左上を選択してください", _
            Title:="セル選択", Type:=8)
    On Error GoTo 0
    If exprng Is Nothing Then Exit Sub
    
Dim t As Single     '処理時間計測用
t = Timer   'ここから処理時間計測開始
    
    Application.ScreenUpdating = False
    rng.Worksheet.Activate
    sr = rng.Row    '開始行取得
    Set rng = rng.CurrentRegion     'データ範囲取得
    er = rng.Rows.Count + sr - 1    '最終行取得
    tgcol = "C1:C" & er             '検索対象列の範囲
    
    'Evaluate に渡すパラメーター作成
    param = "FILTER(" & rng.Address(False, False) & _
        ",IFERROR(SEARCH(""*""&H2&""*""," & tgcol & "),FALSE),""該当なし"")"
    'EvaluateメソッドでFILTER関数の戻り値を取得
    r = Evaluate(param)

    '書き込み範囲の状態を事前に調べる
    exprng.Worksheet.Activate
    Dim msg As String
    Call AddrCheckRange(r, exprng, msg)
    If msg <> "" Then Exit Sub
    
    '戻り値は２次元配列なのでUBoundで範囲をリサイズしてセルに書き込む
    exprng.Resize(UBound(r, 1), UBound(r, 2)) = r
    rng.Worksheet.Activate
    
    'FILTERで抽出した件数をセルに表示
    Range("H3").Value = "抽出件数＝ " _
        & exprng.Resize(UBound(r, 1), UBound(r, 2)).Rows.Count & " 件"
    Application.ScreenUpdating = True
    
'処理時間をセルに書き込む
Range("H18") = Timer - t
End Sub

'書き込み先アドレスの状況を事前チェックする
Sub AddrCheckRange(ByVal r As Variant, _
                    ByVal exprng As Range, _
                    ByRef msg As String)
    Dim addr As String
    Dim rng As Range
    Dim res As Integer
    
    '書き込み先の範囲アドレスを取得
    addr = exprng.Resize(UBound(r, 1), UBound(r, 2)).Address
    '書き込み範囲のアドレスをRangeオブジェクトにセット
    Set rng = Range(addr)

    'セル範囲内に結合セルがあるかを調べる（TrueまたはNullなら存在有）
    If IsNull(rng.MergeCells) Or rng.MergeCells Then
        msg = "書き込み範囲内に結合セルがあります！" _
            & vbCrLf & "（正しく書き込めない可能性があります）" _
            & vbCrLf
        res = MsgBox(msg & "書き込みに支障があるため処理を中止します！" _
                , vbExclamation)
        Exit Sub
    End If
    
    '空白以外のセルが無いかをチェック
    If WorksheetFunction.CountA(rng) <> 0 Then
        msg = "書き込み範囲に空白以外のセルがあります！" _
            & vbCrLf & "　(既存のデータは上書きされます)" _
            & vbCrLf & vbCrLf
    End If
    If msg <> "" Then
        res = MsgBox(msg & "このまま書き込みを実行しますか？" _
                & vbCrLf & "(「はい」=このまま実行、「いいえ」=中止)", _
                vbYesNo + vbExclamation)
        If res = vbYes Then msg = ""
    End If 
End Sub

'Excelのスピル対応状況を確認して処理方法を分岐
Sub FILTER_start()
    'ExcelのBuild番号でスピル対応しているかチェック
    If Application.Build >= 12228.20332 Then
        'スピル対応の場合ワークシート関数の処理へ
        Call wsFuncFILTER_Sample
    Else
        'スピル対応不可の場合のVBA関数の処理へ
        Call ArrayFilterSample
    End If
End Sub

'セル範囲の2次元配列でFilter関数を使ってみる
Sub ArrayFilterSample()
    Dim db As Variant   'セルデ－タ取得用
    Dim sr As Long      '開始行
    Dim sc As Long      '開始列
    Dim er As Long      '最終行
    Dim ec As Long      '最終列
    Dim i As Long, j As Long 'ループ用
    Dim rng As Range    'セル選択用
    Dim exprng As Range '書き込みセル選択用
    
    'Application.InputBoxで対象表を選択させる
    On Error Resume Next
    Set rng = Application.InputBox( _
            Prompt:="表の先頭（左上）セルを１つ選択してください", _
            Title:="セル選択", Type:=8)
    If rng Is Nothing Then On Error GoTo 0: Exit Sub
    '結果を書き出すセル範囲の左上を選択させる
    Set exprng = Application.InputBox( _
            Prompt:="結果を書き出すセル範囲の左上を選択してください", _
            Title:="セル選択", Type:=8)
    On Error GoTo 0
    If exprng Is Nothing Then Exit Sub
    
Dim t As Single     '処理タイム計測用
t = Timer   'ここから処理時間計測開始
    Application.ScreenUpdating = False
    rng.Worksheet.Activate
    sr = rng.Row        '開始行取得
    sc = rng.Column     '開始列取得
    
    '取得セル範囲を2次元配列に一括代入する
    db = Cells(sr, sc).CurrentRegion.Value
    er = UBound(db, 1)   '1次元の最大値（最終行）
    ec = UBound(db, 2)   '2次元の最大値（最終列）
    
    ReDim c(sc To ec) As String
    ReDim r(sr To er) As String
    Dim str As String
    Dim ar As Variant   '一次元配列格納用
    Dim rn As Variant   'セル選択用
    Dim tgr As Long     '書き込み行用
    Dim tgc As Long     '書き込み列用
    
    '2次元配列をJoin関数で行ごとの1次元配列にする
    For i = sr To er
        For j = sc To ec
            c(j) = db(i, j) '1次←2次元
        Next
        r(i) = Join(c, "|") '行ごとに列のセルデータを連結
    Next
    str = Join(r, ",")      '各行毎のデータを全て連結（文字列）
    rn = Split(str, ",")    '文字列を一次元配列へ
    
    'ここでフィルタリングする。指定文字はRange("H2")の値
    ar = Filter(rn, Range("H2"), True, vbTextCompare)
    exprng.Worksheet.Activate
    tgr = exprng.Row
    tgc = exprng.Column
    For i = 0 To UBound(ar)
        'フィルタリングしたデータをセルに書き出す
        Range(Cells(i + tgr, tgc), Cells(i + tgr, tgc + ec - 1)) = _
                                    Split(ar(i), "|")
    Next
    
    '抽出した件数をセルに表示
    rng.Worksheet.Activate
    Range("H3").Value = "抽出件数＝ " & i & " 件"
    
'処理時間をセルに書き込む
Range("H10") = Timer - t
    Application.ScreenUpdating = True
End Sub