Sub CopyFilteredData()
Dim srcRange As Range ' 元データ
Dim critRange As Range ' 条件範囲
Dim destCell As Range ' 転記先セル
'--- 範囲オブジェクトの設定 ---
Set srcRange = Worksheets("Data").Range("B3").Resize(148, 4) ' B3:E150
Set critRange = Worksheets("Criteria").Range("H2:H4") ' 見出し+条件
Set destCell = Worksheets("Result").Range("A1") ' 転記先
'--- AdvancedFilter の実行(抽出結果をコピー)---
srcRange.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=critRange, _
CopyToRange:=destCell, _
Unique:=False ' 重複行を除外したい場合は True に変更
MsgBox "抽出結果を Result シートへ転記しました。", vbInformation
End Sub