【VBA】 可視セルの一部をコピー

質問

ある部品表一覧を管理しています。
その中で、一部の頭文字から始まるコードを除外し、除外したうちの上から10番目までをコピーする作業を行いたいのですが、

最初の一部の頭文字から始まるコードを除外するために、フィルタオプションを用いてフィルタリングを行っている為、通常のトップテン抽出が行えません。
その為、CurrentRegionを用いてのコピーでは、上から10番目までをコピーという作業が行う事が出来ません。
どうにかして、可視セルの一部をコピーする事はできないでしょうか？

///// 例 /////
部品コード 数
A1 10
B1 20
C1 10
C2 20
C3 30
.
.
C100 1000
D1 10

上記で、A/B/Dから始まる品目を除外したうえで、部品コードC1～C10までをコピーしたい

回答No.1

KenKen_SP · ベストアンサー

こんにちは。

> フィルタオプションを用いてフィルタリングを行っている為、
> 通常のトップテン抽出が行えません。

エラー処理は皆無ですけど一案です。要は、可視セルの行でループ

　　For Each rRow in rVisible.Rows
　　Next

させて、10行分（見出しを含め11行）コピーしているだけです。

ただ、下記コードではそれを rSrc という Range コレクション
にまとめてから、１回のコピーで済ませていますが。

Sub Sample()

　　Dim rVisible　As Range
　　Dim rSrc　　　As Range
　　Dim rRow　　　As Range
　　Dim i　　　　 As Long

　　 ' // フィルタ可視セル範囲
　　Set rVisible = ActiveSheet.AutoFilter.Range. _
　　　　　　　　　 SpecialCells(xlCellTypeVisible)

　　i = 0
　　For Each rRow In rVisible.Rows
　　　　i = i + 1
　　　　If rSrc Is Nothing Then
　　　　　　Set rSrc = rRow
　　　　Else
　　　　　　Set rSrc = Union(rSrc, rRow)
　　　　End If
　　　　' // 見出し行を含め行カウンタ i が11行以上でループ終了
　　　　If i >= 11 Then Exit For
　　Next
　　rSrc.Copy Destination:=Worksheets("Sheet2").Range("A1")

　　Set rSrc = Nothing
　　Set rVisible = Nothing

End Sub

お礼

フィルタオプションではAutoFilterで選択が出来ない為なのか、

>Set rVisible = ActiveSheet.AutoFilter.Range._
>SpecialCells(xlCellTypeVisible)

上記部分でエラーが出ましたが、

Set rVisible = ActiveSheet.Range("A2:B100")._
SpecialCells(xlCellTypeVisible)

上記の様に変えて、無事動かす事ができました。

RangeやFor Each文のいい勉強になりました。
ありがとうございました。