'AutoFilterを使い、フィルタとコピーを行うマクロ3

'Testマクロを実行してください。
'Sheet1にテストデータが作成され、Sheet2にフィルタ結果が出力されます。

Option Explicit

'MyAutoFilterRangeを利用するサンプルマクロ

Sub Test()
    Dim range1 As Range, range2 As Range, r As Range
    Dim cnt As Long

    On Error GoTo err_1

    Workbooks.Add(xlWorksheet).Worksheets(1).Name = "Sheet2"
    Worksheets.Add.Name = "Sheet1"

    'テストデータの作成
    With Sheets("Sheet1").Range("A1:C1")
        .Value = Array("Field1", "Field2", "Field3")
        .Offset(1).Value = Array("A", 1, 100)
        .Offset(2).Value = Array("A", 2, 200)
        .Offset(3).Value = Array("A", 3, 300)
        .Offset(4).Value = Array("B", 1, 400)
        .Offset(5).Value = Array("B", 2, 500)
    End With

    'リスト範囲の指定
    Set range1 = Sheets("Sheet1").Cells(1, 1).CurrentRegion

    'コピー先範囲の指定
    Set range2 = Sheets("Sheet2").Cells(2, 2)

    'コピー先範囲のクリア
    range2.Worksheet.Cells.Clear

    Application.ScreenUpdating = False

    'フィルタの実行
    Set r = MyAutoFilterRange(range1, Array(Array(2, ">=2", xlAnd, "<=3")))

    If r Is Nothing Then
        cnt = 0
    Else
        'B列とC列の見出し行を除く範囲をコピー
        Application.Intersect(r, range1.Columns(2).Resize(, 2)).Copy

        '値のみ貼り付け
        range2.PasteSpecial xlValues

        'コピーモードの解除
        Application.CutCopyMode = False

        'フィルタ結果の行数を取得
        cnt = MyAreasRowsCount(r)
    End If

    MsgBox cnt & " 行コピーしました。", vbInformation, "フィルタとコピー"
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, "フィルタとコピー"
End Sub


'複数範囲の行数を取得する関数
Function MyAreasRowsCount(range1 As Range) As Long
    Dim r As Range
    Dim cnt As Long
    cnt = 0
    For Each r In range1.Areas
        cnt = cnt + r.Rows.Count
    Next
    MyAreasRowsCount = cnt
End Function

'オートフィルタを実行し、結果の範囲を返す関数
Function MyAutoFilterRange(range1 As Range, criteria As Variant) As Range
    Dim i As Integer, lb As Integer, ub As Integer

    Set MyAutoFilterRange = Nothing

    'オートフィルタの解除
    range1.Worksheet.AutoFilterMode = False

    '見出し行だけの場合は中断する
    If range1.Rows.Count = 1 Then Exit Function

    'オートフィルタの実行
    For i = LBound(criteria) To UBound(criteria)
        lb = LBound(criteria(i))
        ub = UBound(criteria(i))
        Select Case ub - lb
            Case 1
                range1.AutoFilter _
                    Field:=criteria(i)(lb), criteria1:=criteria(i)(ub)
            Case 3
                range1.AutoFilter _
                    Field:=criteria(i)(lb), criteria1:=criteria(i)(lb + 1), _
                    operator:=criteria(i)(lb + 2), criteria2:=criteria(i)(ub)
            Case Else
                range1.Worksheet.AutoFilterMode = False
                Exit Function
        End Select
    Next

    '見出し行を除いた範囲を取得する
    With range1.Resize(range1.Rows.Count - 1).Offset(1)

        'フィルタ結果があるかチェック
        If .Height > 0 Then

            '単一セルかチェック
            If .Cells.Count = 1 Then

                '単一セルの場合はそのセルを返す
                Set MyAutoFilterRange = .Cells
            Else

                '可視セル範囲を取得して返す
                Set MyAutoFilterRange = .SpecialCells(xlVisible)
            End If
        End If
    End With

    'オートフィルタを解除する
    range1.Worksheet.AutoFilterMode = False
End Function