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

'アクティブブックに、Sheet1、Sheet2、Sheet3 のワークシートを用意し、
'Testマクロを実行してください。
'Sheet1にテストデータ、Sheet2に検索条件範囲が作成され、Sheet3に
'フィルタ結果が出力されます。

Option Explicit

'MyAdvancedFilterCopy()を利用するサンプルマクロ

Sub Test()
    Dim range1 As Range, range2 As Range
    Dim criteriaRange As Range
    Dim ret As Long

    On Error GoTo err_1

    'テストデータの作成
    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 criteriaRange = Sheets("Sheet2").Cells(1, 1)
    
    'コピー先範囲の指定
    Set range2 = Sheets("Sheet3").Cells(1, 1)

    '検索条件範囲とコピー先範囲のクリア
    criteriaRange.Worksheet.Cells.Clear
    range2.Worksheet.Cells.Clear

    '検索条件範囲の作成
    With criteriaRange
        .Cells(1, 1).Value = "Field1"
        .Cells(2, 1).Value = "'=A"
        .Cells(1, 2).Value = "Field3"
        .Cells(2, 2).Value = "=200"
    End With
    Set criteriaRange = criteriaRange.CurrentRegion

    Application.ScreenUpdating = False

    'フィルタとコピーの実行
    ret = MyAdvancedFilterCopy(range1, criteriaRange, False, range2)
    MsgBox ret & " 行コピーしました。", vbInformation, "フィルタとコピー"
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, "フィルタとコピー"
End Sub


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

Function MyAdvancedFilterCopy(source As Range, _
    criteriaRange As Range, Unique As Boolean, _
    destination As Range) As Long

    'データがない場合は0を返す
    If source.Rows.Count = 1 Then
        MyAdvancedFilterCopy = 0
        Exit Function
    End If

    'フィルタの実行
    source.AdvancedFilter Action:=xlFilterInPlace, _
        criteriaRange:=criteriaRange, Unique:=Unique

    'コピー
    source.Copy destination

    'フィルタのリセット
    MyShowAllData source

    'コピーしたデータ行数を返す
    MyAdvancedFilterCopy = destination.CurrentRegion.Rows.Count - 1
End Function


Sub MyShowAllData(range1 As Range)
    If range1.Worksheet.FilterMode Then
        range1.Worksheet.ShowAllData
    Else
        range1.AutoFilter Field:=1
        range1.AutoFilter
    End If
End Sub