抽出データを新規ブックにコピーするマクロ

Excelで集計・抽出作業をしていると、
作業の対象データだけを別ブックにコピーしたいことがよくあります。

この処理、フィルターで選んで実行できると楽なのですが、
意外とこれを簡単に行う方法がなく、

• フィルター中のデータをそのままコピーすると列幅などがついてこない
• フィルターしていないデータを削除するのは処理が重い

あたりがネックで、手作業だと意外に面倒です。

ということで、こちらを一発で実行するマクロを作ってしまいましょう。

実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。

ショートカットキーに登録したり、ツールバーやリボンにボタン配置すると便利です。

ソースコード

Sub 抽出中のデータのみを新規ブックにコピーする()
    
    Dim ws対象シート As Worksheet
    Set ws対象シート = ActiveSheet
    
    ' フィルター抽出中でなければExit
    If ws対象シート.FilterMode = False Then: MsgBox "フィルターに抽出がかかっていません。": Exit Sub
    
    ' 元シートをテンプレートとして活用するために別ブックにコピー
    ws対象シート.Copy
    Dim ws出力シート As Worksheet
    Set ws出力シート = ActiveSheet
    
    ' 元シートの見出しより上を残してすべて削除
    ws出力シート.ShowAllData
    GetRangeフィルターデータ部(ws出力シート).EntireRow.Delete
    
    ' 対象シートの抽出注のデータ部分を出力シートへコピー
    GetRangeフィルターデータ部(ws対象シート).Copy ws出力シート.AutoFilter.Range.Cells(2, 1)
    
End Sub

' フィルターデータエリアの取得
Function GetRangeフィルターデータ部(ws対象シート As Worksheet) As Range
    If ws対象シート.AutoFilterMode = False Then Exit Function
    Set GetRangeフィルターデータ部 = ws対象シート.AutoFilter.Range
    Set GetRangeフィルターデータ部 = GetRangeフィルターデータ部.Offset(1)
    Set GetRangeフィルターデータ部 = GetRangeフィルターデータ部.Resize(GetRangeフィルターデータ部.Rows.Count - 1)
End Function

解説

フィルター中のデータに対して、
「フィルターされていないデータだけを消す」のは結構面倒です。

フィルター中のデータをマークしてからいったん解除し、
マークの無いデータを削除するなどの工程が必要になります。

面倒さの割に飛び飛びの複数行の削除は処理が重くなることも多いため、今回は

1. 一旦シートごと全データをコピー
2. コピーシートのフィルターをクリアして全データを削除
   ↑この見出しより上だけ残ったシートをテンプレートとして使う
3. あらためて元のシートから抽出データだけをコピー

という手順を踏みました。

一見、不必要な量のデータをコピーしていて無駄なように見えますが、
複数の行を削除する処理はエリアごとにDeleteメソッドが動く仕様のため、
処理速度・消費メモリ共にこちらの方が優秀なロジックになります。

プログラムは意外とモレなくダブりなく行う処理より、
ダブってもいいから一括で処理できる方法をとった方が効率的な場合が多いです。

コーディングもこちらが楽ですし、この性質は覚えておいてください。