エクセルＶＢＡのオートフィルタについて

質問

オートフィルタ後の範囲選択で教えてください。

１行目にタイトルがある表で
Range("a1").AutoFilter Field:=2, Criteria1:="ＰＣ"
Range("A1").CurrentRegion.Select

と実行すると１行目のタイトル行を含めて商品がＰＣの行が
セレクトされます。
オートフィルタを何度も実行した結果を別シートにまとめる為
２回目以降はタイトル行を含めずにセレクトしたいのですが
やり方がわかりません。お知恵をお貸しください。

回答No.4

pauNed · ベストアンサー

こんにちは。

.AutoFilter.Rangeを使っても良いかもしれません。
また、抽出対象がない時、見出し行を含まずコピーすると、
非表示データ全部がコピーされてしまいますから、気をつけたほうが良いと思います。

With ActiveSheet
　　If .AutoFilterMode Then
　　　　With .AutoFilter.Range
　　　　　　If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
　　　　　　　　Intersect(.Cells, .Offset(1)).Copy _
　　　　　　　　　　Destination:=Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　　　End If
　　　　End With
　　End If
End With

お礼

pauNedさん。試してみたらばっちりで
早速使わせていただきます。ありがとうございました。
対象０件パターンもSubtotalでひっかけられました。
Intersectは、「こんなのどんな時に使えるの？」って思うくらいのすごいマニアックな関数ですね。
オートフィルタは、表示する分にはすごく便利ですが
そのデータを使おうとすると見えない行に邪魔されますね。
今回始めて使うにあたって全然わからなかったです。
またわからないことがあったらよろしくお願いします。

補足

回答ありがとうございます。

Intersectは初めてです。
後ほど結果報告させていただきます。

回答No.8

ka_na_de

ka_na_deです。

質問者さん以外にコメントすることは極力控えているのですが、
Wendy02さんの回答を拝見して、どうしてもコメントしたくなりました。

すごいです。
見ればみるほど雲が晴れていきます。
なるほどー。こう書くのかー。
遊びでEXCELをいじり始めて２ヶ月ですが、
本当に奥が深いですね。
自分もこんな風にすっきり書きたいのですが、
まだまだ未熟なせいでエラーと格闘しながら
対処療法で記述しているのが現状です。

これからも、勉強させてください。
ありがとうございました。

（rex9200さん　横道にそれてごめんなさいね。）

お礼

ka_na_deさん、Wendy02さんへ。
ポイントがあと一人しかお付けできない為
今回お二人とも無しとさせて頂きました。
ごめんなさい。

お二人のていねいな回答に感謝しておりますので
今後ともよろしくお願いします。

補足

いえいえどういたしまして。
私も仕事で必要にせまられて春から始めましたが
ＶＢＡの豊富な機能には驚くばかりです。

基本から勉強ではなく必要な部分をテキストから
見よう見まねで取り込んでいるので試行錯誤の連続ですが、
会社のエクセルはヘルプファイルが無いのでとても困ります。
そういう時はつい慣れたＣＯＢＯＬチックなコーディングで
逃げているのできっと効率の悪いＶＢＡだろうと思ってます。
（この前セル操作を定番のコードと比較したら４割位遅かったですね）
でも目検では絶対出来ないチェックや手作業では嫌になるような大量作業がオートで動くさまは気持ちいいですね。
またよろしくお願いします。

回答No.7

Wendy02

こんばんは。

すでに、回答は出ていますが、私の書いたポイントをまとめておきます。

Dim r As Range
Dim Dest As Range
Set Dest = Worksheets("Sheet2").Range("A1") '貼り付け先
With Worksheets("Sheet1") 'オートフィルタのあるシート
　.Range("A1").AutoFilter Field:=2, Criteria1:="PC" '検索値
　Set r = .AutoFilter.Range

　If IsEmpty(Dest) Then r.Rows(1).Copy Dest　'タイトルコピー

　'ここで、Visible のセルをカウントする
　If r.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then

　'これで見えるものだけのコピーは出来る
　　r.Offset(1).Resize(r.Rows.Count - 1).Copy _
　　 Dest.Parent.Range("A65536").End(xlUp).Offset(1)
　End If　
End With
　Set r = Nothing
　Set Dest = Nothing

お礼

Wendy02さん、いつもありがとうございます。
Wendy02さんのコードは、私のように本のサンプルしか
しらない素人には最初はとっつきにくい（失礼）ですが
Ｎｏ．１の方が書かれているように、とても勉強になります。
今後ともよろしくご教授ください。

回答No.6

ka_na_de

＃１です。

Ｎｏ１の回答で選択後に手動でコピー＆ペーストができたので、
tbl.Rows.Countの値を使わずにコピーしていくマクロを作ってみました。
本来は他の回答者さんのようにきちんと選択しないといけないのでしょうが・・・
難しかったので、場当たり的に作ってしまいました。ご参考までに。

Sheet1に表があって、２列目をＰＣ,aaa,bbb,cccの項目で抽出して
空白シートのSheet2へ並べていく例です。

Sub test()
　Dim ITEM
　Dim i As Integer

　'抽出する項目
　ITEM = Array("ＰＣ", "aaa", "bbb", "ccc")

　'Sheet1の見出し行をSheet2へコピー
　Worksheets("Sheet1").Rows("1:1").Copy _
　　　Destination:=Worksheets("Sheet2").Rows("1:1")

　'Sheet1の表の２列目で項目を抽出後、Sheet2のデータ末尾にコピー
　For i = LBound(ITEM) To UBound(ITEM)
　　Call filter_copy("Sheet1", 2, ITEM(i), "Sheet2")
　Next i

End Sub

Public Function filter_copy(Sheet_1 As String, field_NO As Integer, _
　　　　　　　　　　　　name As Variant, Sheet_2 As String)
　Dim tbl As Object

　Worksheets(Sheet_1).Select
　Range("A1").AutoFilter Field:=field_NO, Criteria1:=name
　Range("A1").Select

　Set tbl = ActiveCell.CurrentRegion
　tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select

　Selection.Copy _
　　　Destination:=Worksheets(Sheet_2).Cells(65536, "A").End(xlUp).Offset(1, 0)

End Function

お礼

サンプルコーディングありがとうございます。
試しましたところ、やはり　Filterで対象０件の時
全件貼りついてしまいました。

回答No.5

ka_na_de

おはようございます。

エラーは一旦解決されたようですね。

＃１のマクロ実行後、手動でコピー＆ペーストして
問題なかったので、これでよしと回答してしまいました。

選択後に、次の処理でtbl.Rows.Countの値を使って、
余計な行が張り付いたのでしょうね。

だとすると、Wendy02が回答しているように、
SpecialCells で、xlCelltypeVisible の条件でカウントする必要があると思います。

なお、pauNedさんの回答のIntersectは初めて知りました。
勉強になります。これから調べてみようと思います。

尚、すべて解決された折は、最終形を公開していただけたら幸いです。
勉強させていただきたいので、よろしくお願いします

回答No.3

Wendy02

こんばんは。

横からすみません。

tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select

仮に、
tbl.Rows.Count - 1
　↑
ここが、1 になることはありえませんが、仮に、ここが、1でも、Resizeには、-1　にならなければ、そのような、「実行時エラー」は出ません。エラーの原因は、大方、別のシートモジュールに書いているせいではないでしょうか？正しいシートモジュールか、標準モジュールに貼り付けているのでしょうか？なお、行数を取るのでしたら、SpecialCells で、xlCelltypeVisible の列ひとつのセルを数えるのだとは思います。

お礼

アドバイスありがとうございます。
Range("A1").CurrentRegion.Selectをコメント化していました。
普通はSet tbl = ActiveCell.CurrentRegionのコードだけで
表がtblにセットされるので不要と思いカットしていましたが
戻したらエラーは出なくなりました。
ただ対象があってもなくても、tbl.Rows.Countには全件数が入って
おり、かつ対象が０の時はすべての行が貼り付いてしまいました。
対象有無の判断として行数カウントを入れて見ます。

回答No.2

ka_na_de

tbl.Rows.Count =1
になっているということは、見出し行しか存在せず、
データがまだ入力されていないということでしょうか？

もし、そのような場合が存在するのなら、
以下でどうですか？
もちろんデータが無いのでリサイズしません。（見出しのみ選択）

Sub test()

Range("a1").AutoFilter Field:=2, Criteria1:="ＰＣ"
Range("A1").CurrentRegion.Select

Set tbl = ActiveCell.CurrentRegion
If tbl.Rows.Count = 1 Then Exit Sub
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select

End Sub

お礼

追加回答ありがとうございます。
Range("A1").CurrentRegion.Selectをコメント化していました。
普通はSet tbl = ActiveCell.CurrentRegionのコードだけで
表がtblにセットされるので不要と思いカットしていましたが
戻したらエラーは出なくなりました。
ただ対象があってもなくても、tbl.Rows.Countには全件数が入って
おり、かつ対象が０の時はすべての行が貼り付いてしまいました。

回答No.1

ka_na_de

これでどうですか？

Sub test()

Range("a1").AutoFilter Field:=2, Criteria1:="ＰＣ"
Range("A1").CurrentRegion.Select

Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select

End Sub
コードはヘルプから抜粋しました。

補足

回答ありがとうございます。
試すと「実行時エラー　1004」となってしまいました。
tbl.Rows.Countの値が何故か１になっています。
行数が１－１で０となった為だと思われます。

一旦、どこかに貼り付けてからＲｅｓｉｚｅするしか
方法が無いのでしょうか。