エクセル フィルタオプションについて

質問

教えて下さい。
sheet1～sheet3まであります。
【sheet1】と【sheet2】をフィルタオプション
で検索条件範囲が【記号】部分で、
【sheet3】の結果になりますが、
VBAで、どのようにすれば良いのか
わかりません。

Sheets("Sheet1").Range("A1:C3").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3:C150"), Unique:=False

Sheets("Sheet2").Range("A1:C6").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3:C150"), Unique:=False
End Sub

このプログラムで実行するとSheet2の抽出しか
できません。
何が足りないのでしょうか？
宜しくお願いします。

【sheet1】
A B C
品名 金額 記号
1 いちご 100 06-02
2 りんご 200 06-01
3 みかん 300 06-02

【sheet2】
A B C
品名 金額 記号
1 いちご 500 06-01
2 りんご 1000 06-01
3 みかん 1500 06-02

【sheet3】
A B C
1 記号
2 06-02
3 品名 金額 記号
4 いちご 100 06-02
5 みかん 300 06-02
6 みかん 1500 06-02

回答No.1

taocat

おはようございます。

抽出結果を表示するセル範囲が同じ（A3:C150）になってますから
Sheet1の結果の上にSheet2の結果が上書きされてるだけです。
それを避けるためにSheet2の抽出結果を表示するセルは
Sheet1の抽出結果の最後のセルの次のセルを指定ればいいわけです。
そして最後に、Sheet2の見出しも抽出されてますからそれを削除。

---------------------------------------------------------------
Sub Test()

　　　Dim myCell As Range

Sheets("Sheet1").Range("A1:C2000").AdvancedFilter Action:=xlFilterCopy, _
　CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3"), Unique:=False

　　　Set myCell = Range("A65536").End(xlUp).Offset(1)

Sheets("Sheet2").Range("A1:C2000").AdvancedFilter Action:=xlFilterCopy, _
　CriteriaRange:=Range("A1:A2"), CopyToRange:=myCell, Unique:=False

　　　myCell.EntireRow.Delete xlShiftUp

End Sub
--------------------------------------------------------------------------

それから抽出範囲は範囲の左上をひとつ指定する。
またリスト範囲は、データの追加にも耐えられるように余分に設定することをお勧めします。
例えば、A1:C2000　とか(上記コード）
一行目が見出し行であれば、あっさりと列全体、A:C　とか。

以上です。

補足

こんばんは。
taocatさんありがとうございました。
実行してみました。
1度目は、出来ました！！続けて
違う記号【06-01】を実行すると
エラーがでました。
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3"),Unique:=False
の部分を
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3:C2000"),Unique:=False
に、変更したらいけました。

Sub Test()

Dim myCell As Range

Sheets("Sheet1").Range("A1:C2000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("A3:C2000"), Unique:=False

Set myCell = Range("A65536").End(xlUp).Offset(1)

Sheets("Sheet2").Range("A1:C2000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=myCell, Unique:=False

myCell.EntireRow.Delete xlShiftUp

>Range("A65536").End(xlUp).Offset(1)
このコードを教えてもらい勉強になりました。
今後、色々と利用できると思いますので
忘れないようにしたいです。