Excel VBA オートフィルタの結果をコピーして貼り付けたい（空白行も含める）

Question

オートフィルタ結果をコピーして、別シートに貼り付けるというマクロとなります。

しかし、これですと絞り込んだ対象の中に空白の行があると、空白行の上までの部分しかコピーをすることができません。
そこで、登録のシートの空白行は削除することなく、
抽出のシートで空白行を削除して貼り付けをしたいのですが、
こうしたことは可能でしょうか。
もし可能でしたら、どのようなコードを追記すればよろしいでしょうか。
よろしくお願い致します。

＞

Sub ()
 Const SHEET_COPY As String = "登録"
Const SHEET_PASTE As String = "抽出"

Worksheets(SHEET_COPY).Range("a2:e" & _
 Worksheets(SHEET_COPY).Range("a1").CurrentRegion.Rows.Count).Copy
 Worksheets(SHEET_PASTE).Range("a" & _
 Worksheets(SHEET_PASTE).Range("a1").CurrentRegion.Rows.Count + 1).PasteSpecial Paste:=xlPasteValues
 Sheets("抽出").Select
End Sub

WindFaller · Accepted Answer

図を入れることを忘れたのと修正部分があります。
たぶん、このようなマクロでも、おそらくは満足はされないとは思いますが、参考ぐらいにはなるはずです。

修正部分：一箇所：横に一つずれる

OpRng.CurrentRegion.ClearContents '貼り付け先のデータの削除
　　If Sh1.AutoFilterMode = False Then Exit Sub
　　Set Rng = Sh1.AutoFilter.Range
　　j = 2
　　Rng.Rows(1).Offset(, 1).Copy OpRng.Cells(1)　　'※修正
　　For rw = 2 To Rng.Rows.Count
　　　　If WorksheetFunction.Subtotal(3, Sh1.Cells(rw, 2)) > 0 Then
　　　　　　OpRng.Cells(j, 1).Resize(, Rng.Columns.Count).Value = _
　　　　　　Sh1.Cells(rw, 2).Resize(, Rng.Columns.Count).Value
　　　　　　j = j + 1
　　　　End If
　　Next rw
End Sub

tokuma. · Answer

>AutoFilter で間が空くような現象
フィルターの条件を複数指定して、条件の１つに(空白セル)を入れるとか？
(＝特定のコード１つのみ除外して残りのデータは全て残したい場合など)

>Range("a1").CurrentRegion.Rows.Count + 1).PasteSpecial Paste:=xlPasteValues
わざわざこう書く場合は、貼り付け先に既にデータがあるという事ではないのでしょうか。
つまり、元々のコードは過去データに追記していくような仕様で設計されているとか？
※提示されたコードを２回実行すれば動きが確認できると思います。
その場合、空白を含んではいけない仕様になります。

[予想]
どこかからコード流用。そのコードは過去データに追記する仕様(空白セルを含んではいけない前提)
↓
質問者が元コードの仕様を理解せず、自分の都合で空白セルを含む仕様を追加して質問。

WindFaller · Answer

このご質問を注意深く読んでみましたが、再現性が今ひとつ取れません。何か、一つの条件が抜けているようです。

>これですと絞り込んだ対象の中に空白の行があると、空白行の上までの部分しかコピーをすることができません。

これ自体は、CurrentRegion が原因だとしても、AutoFilter で間が空くような現象が、あるとは思えないのです。(図1）
どのようなデータの並びになっているのか教えていただきたいです。

Range("a1").CurrentRegion.Rows.Count + 1).PasteSpecial Paste:=xlPasteValues

これも意味不明です。
いずれにしても、SpecialCells やPastSpecial メソッドで可能になるかどうかは、内容が単純でないので、簡単ではありません。本来ファイルターで工夫したほうが早いような気がします。

'//
Sub TestFilterCopyw_oBlank()
　　Const SHEET_COPY As String = "Sheet2" '"登録"
　　Const SHEET_PASTE As String = "Sheet3" '"抽出"
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim Rng As Range
　　Dim rw As Long, j As Long
　　Dim OpRng As Range
　　'**************設定*****
　　Set Sh1 = Worksheets(SHEET_COPY)
　　Set Sh2 = Worksheets(SHEET_PASTE)
　　Set OpRng = Sh2.Range("A1") '貼り付け先／タイトル行を想定しているので2行目から
　　'******************
　　OpRng.CurrentRegion.ClearContents '貼り付け先のデータの削除
　　If Sh1.AutoFilterMode = False Then Exit Sub
　　Set Rng = Sh1.AutoFilter.Range
　　j = 2
　　Rng.Rows(1).Copy OpRng.Cells(1)　'タイトル行のコピー
　　For rw = 2 To Rng.Rows.Count
　　　　If WorksheetFunction.Subtotal(3, Sh1.Cells(rw, 2)) > 0 Then
　　　　　　OpRng.Cells(j, 1).Resize(, Rng.Columns.Count).Value = _
　　　　　　Sh1.Cells(rw, 2).Resize(, Rng.Columns.Count).Value
　　　　　　j = j + 1
　　　　End If
　　Next rw
End Sub
'//

izayoimizuki · Answer

流れとしては…
SpecialCells(xlCellTypeAllValidation)で範囲を取得→コピー→ペーストで行けます。

Excel VBA オートフィルタの結果をコピーして貼り付けたい（空白行も含める）

図を入れることを忘れたのと修正部分があります。

>AutoFilter で間が空くような現象

このご質問を注意深く読んでみましたが、再現性が今ひとつ取れません。

流れとしては…

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング