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

オートフィルタ結果をコピーして、別シートに貼り付けるというマクロとなります。

しかし、これですと絞り込んだ対象の中に空白の行があると、空白行の上までの部分しかコピーをすることができません。
そこで、登録のシートの空白行は削除することなく、
抽出のシートで空白行を削除して貼り付けをしたいのですが、
こうしたことは可能でしょうか。
もし可能でしたら、どのようなコードを追記すればよろしいでしょうか。
よろしくお願い致します。

＞

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

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2016/05/25 19:11

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

たぶん、このようなマクロでも、おそらくは満足はされないとは思いますが、参考ぐらいにはなるはずです。

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

　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

この回答へのお礼

修正追加ありがとうございました。
コード表記も非常にありがたいです。
参考にさせていただきます。

お礼日時：2016/06/17 17:21

No.4 回答者： tokuma. 回答日時： 2016/05/26 10:06

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

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

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

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

この回答へのお礼

ありがとうございました。
お礼が遅れましたこと、お詫びします。
コードの表記までありがとうございます。
参考にさせていただきます。

お礼日時：2016/06/17 17:20

No.2 回答者： WindFaller 回答日時： 2016/05/25 19:02

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

何か、一つの条件が抜けているようです。

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

これ自体は、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
'//

この回答へのお礼

ありがとうございました。
お礼が遅れましたこと、お詫びします。

お礼日時：2016/06/17 17:21

No.1 回答者： izayoimizuki 回答日時： 2016/05/24 22:07

流れとしては…

SpecialCells(xlCellTypeAllValidation)で範囲を取得→コピー→ペーストで行けます。

この回答へのお礼

ありがとうございました。
お礼が遅れましたこと、お詫びします。

お礼日時：2016/06/17 17:21