事前に[設定]シートに条件を設定
↓
Sheet1 に元データがある
↓
Sheet2 へデータを映して加工する
↓
Sheet3 に抽出結果を出力する
≪コード≫
'[設定]シートにある抽出条件以外のデータを抜き出す
Const myFlag As String = "不要"
Dim x As Long
Dim i As Long
Dim myFiNo As Long
Dim myStr As String
'前回設定したフィルタが残っていることを考えて二回クリアを実行する
With Sheets("Sheet2")
.Cells.Clear
.Cells.Clear
'Sheet1 を Sheet2 にコピーする
Sheets("Sheet1").Range("A1").CurrentRegion.Copy .Range("A1")
'[Sheet2]を並べ替えることでSpecialCellsを使用したときにエラーが生じにくくなる
.Range("A1").CurrentRegion.Sort Key1:=.Cells(2, myFiNo), Order1:=xlAscending, Header:=xlYes
'Sheet2の1行目のもっとも右に抽出非対称項目を設定する
x = .Range("A1").CurrentRegion.Columns.Count + 1
.Cells(1, x).Value = myFlag
'フィールド番号を把握する
i = 2
Do While .Cells(1, i).Value <> ""
If Sheets("設定").Cells(1, "A").Value = .Cells(1, i).Value Then
myFiNo = i
Exit Do
End If
i = i + 1
Loop
'[設定]シート-A列を元に不要なデータに印をつける
i = 2
Do While Sheets("設定").Cells(i, "A").Value <> ""
myStr = Sheets("設定").Cells(i, "A").Value
.Range("A1").AutoFilter Field:=myFiNo, Criteria1:=myStr
'可視セルの[非抽出]列に印をつける
.Columns(x).SpecialCells(xlVisible).Value = myFlag
i = i + 1
.AutoFilterMode = False
Loop
'[Sheet3]シートにデータをコピーする準備
Sheets("Sheet3").Cells.Clear
'[Sheet2]シ―トから[Sheet3]シートへ不要なデータ以外(必要なデータのみ)を抽出
'[設定]シート-C1~C2セルに事前に設定をしておく
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet3").Range("A1"), _
CriteriaRange:=Sheets("設定").Range("C1:C2"), _
Unique:=True
'ダミーで作った項目名を消す
Sheets("Sheet3").Cells(1, x).Clear
End With