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

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

Option Explicit

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

Sub Test()
    Dim range1 As Range, range2 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

    'フィルタの実行
    If MyAutoFilter(range1, Array(Array(2, ">=2", xlAnd, "<=3"))) Then

        'B列とC列の見出し行を除く範囲をコピー
        With range1.Columns(2).Resize(, 2)
            .Resize(.Rows.Count - 1).Offset(1).Copy
        End With

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

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

        'フィルタ結果の行数を取得
        'cnt = range1.Columns(1).SpecialCells(xlVisible).Cells.Count - 1
        cnt = MyAreasRowsCount(range1.SpecialCells(xlVisible)) - 1
    Else
        cnt = 0
    End If

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

    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 MyAutoFilter(range1 As Range, criteria As Variant) As Boolean
    Dim i As Integer, lb As Integer, ub As Integer

    MyAutoFilter = False

    'オートフィルタの解除
    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
                Exit Function
        End Select
    Next

    'フィルタ結果の有無を返す
    If range1.Resize(range1.Rows.Count - 1).Offset(1).Height > 0 Then
        MyAutoFilter = True
    End If
End Function