Excelマクロ オートフィルタ可視領域の特定部分をコピー

何方か、回答をお願いします。
下記もマクロは 、B列:C列（B1:C1はタイトル）をオートフィルタに掛けて
フィルタに掛かった一番上のデータをコピーして貼り付けているマクロですが。

やりたいことは、B1:C1のタイトルとフィルタに掛かった可視領域の一番上の
データ（オートフィルタに引っかからないでデータが無い場合も有り）をコピー
して貼り付けたいのですがどの様なコードを書けば良いのでしょうか。？

Sub フィルタ()
Range("B1:C1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:=">=1e-6"
Range("B1").CurrentRegion.Select
On Error Resume Next
Selection.SpecialCells(xlCellTypeVisible).Areas(2).Rows(1).Select
Selection.Copy
Range("K15").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFilter
End Sub

No.2 ベストアンサー 回答者： pauNed 回答日時： 2006/11/17 17:38

こんにちは。

ご提示のコードの仕様だと
Sub sample()
　　With Range("B1").CurrentRegion
　　　　.AutoFilter Field:=2, Criteria1:=">=1e-6"
　　　　If Range("B65536").End(xlUp).Row > 1 Then
　　　　　　.Offset(1).SpecialCells(xlCellTypeVisible).Rows(1).Copy Range("K15")
　　　　End If
　　　　.AutoFilter
　　End With
End Sub
こんな感じ。

B1:C1のタイトルも必要なら
Sub sample2()
　　Dim n As Long
　　With Range("B1").CurrentRegion
　　　　.AutoFilter Field:=2, Criteria1:=">=1e-6"
　　　　If Range("B65536").End(xlUp).Row > 1 Then
　　　　　　n = .Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Row
　　　　　　Range("B1:C" & n).Copy Range("K15")
　　　　End If
　　　　.AutoFilter
　　End With
End Sub

この回答へのお礼

回答ありがとう御座います。
オートフィルタに引っかかるデータ有り・無しどちらでも
エラーも出ずに上手くいきました。

お礼日時：2006/11/17 21:25

No.3 回答者： Wendy02 回答日時： 2006/11/17 17:42

こんにちは。

Wendy02です。

今回のは、前回のワークシートの延長上にあるのですね。
これは、1万行でもあれば、またコードも変わりますが、1,000個のデータぐらいだったら、こんな風でもよいのではないかと思います。

>B1:C1のタイトルとフィルタに掛かった可視領域の一番上のデータ
ということでしたら、オートフィルタを使用しないで、このようなコードで成り立つのではないかと思います。ただ、その後に、作業が続くのなら、このコードは成り立ちません。

Sub PickUpData()
Dim i As Long
Dim j As Integer
　With ActiveSheet
　With .Range("B1").CurrentRegion
　　 .Cells(1, 1).Resize(, 2).Copy .Range("K15").Offset(j)
　　 j = 1
　　For i = 2 To .Rows.Count
　　　 If .Cells(i, 2).Value >= 1 * 10 ^ -6 Then
　　　　　.Cells(i, 1).Resize(, 2).Copy .Range("K15").Offset(j)
　　　　　Exit For
　　　 End If
　　Next i
　 End With
　End With
End Sub


前回の回答のグラフの件では、失礼しました。hibohiboさんのExcelのバージョンは、「Excel 2000」あたりですね。前回、どうしても、こちらでは解決できない部分が存在していました。それで後から、Excel 2000 だとすれば、そのエラーは納得行くという結論に達しました。前回のものは、直接、ここではお書きしませんが、時々、バージョンに関わる部分があります。今回も、Excel 2003 でしか調べてはおりません。

この回答へのお礼

Wendy02様、前回そして今回も回答ありがとう御座います。
なるほど、オートフィルタを使わないタイプですね。
>=1e-6に引っかかるデータ有り・無しどちらでも
エラーも出ずに上手くいきました。
今回も、勉強になるコードありがとう御座いました。

お礼日時：2006/11/17 21:32

No.1 回答者： FEX2053 回答日時： 2006/11/17 15:06

色々な方法はありますが一番簡単で分かりやすいのは、

「オートフィルタで抽出したセルを一旦全部どこかに貼り付け、
　貼り付け先で"先頭2行"以外消してしまう、または"先頭2行"
　のみをもう一度コピー／貼り付けする」

です。ですので質問者さんのコードで言えば

Range("K15").Select
ActiveSheet.Paste

で、K15セル以下に抽出結果を全件貼り付けた後に

Range("K15:L16").Copy
Range("N15").Select
Activesheet.paste

で、先頭2行を別の場所（この場合N15）に貼り付ける方法でしょうね。

この回答へのお礼

回答ありがとう御座います。
参考にしたいと思います。

お礼日時：2006/11/17 21:20