【VBA】フィルター結果を新しいブックに保存する方法｜抽出データを自動で別ファイル化する実務テクニック

Excelでデータを扱っていると、「特定条件で抽出したデータを別ファイルとして保存したい」というケースは非常に多いです。
たとえば、

• 支店別にデータを分けて別ファイルで配布したい

• フィルターで絞ったデータだけを納品用として保存したい

• 抽出結果を手動でコピーして新しいExcelに貼る手間をなくしたい

こうした作業を手作業で行うと、コピー＆保存を何度も繰り返す必要があり、時間もかかります。
しかし、VBAマクロで自動化すれば、フィルター結果を一瞬で新しいブックに保存することが可能です。

この記事では、「VBAでフィルター結果を新しいブックに保存する方法」を、基本構文から応用・実務例まで詳しく解説します。

✅ フィルター結果を新しいブックに保存する基本構文

まずは、最も基本的な流れから見ていきましょう。
VBAで行う処理の順序は以下の通りです。

・処理の流れ

1. 元データにフィルターを設定

2. 条件に合致するデータを抽出

3. 抽出された可視セル（表示中のセル）をコピー

4. 新しいブックを作成

5. 新しいブックに貼り付け

6. 名前を付けて保存

・基本VBAコード

Sub SaveFilteredDataToNewBook()
    Dim wsSrc As Worksheet
    Dim wbNew As Workbook
    Dim rngVisible As Range
    Dim savePath As String
    
    '元データシートを指定
    Set wsSrc = Worksheets("売上データ")
    
    '既存フィルタを解除
    wsSrc.AutoFilterMode = False
    
    'フィルタ設定（例：売上金額が100000以上）
    wsSrc.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=">=100000"
    
    '可視セル（抽出結果）を取得
    On Error Resume Next
    Set rngVisible = wsSrc.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rngVisible Is Nothing Then
        MsgBox "該当データがありません。", vbInformation
        Exit Sub
    End If
    
    '新しいブックを作成
    Set wbNew = Workbooks.Add
    
    '抽出データをコピーして貼り付け
    rngVisible.Copy Destination:=wbNew.Sheets(1).Range("A1")
    
    '保存パス設定（元ブックと同じフォルダに日時付きで保存）
    savePath = ThisWorkbook.Path & "\抽出結果_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    
    '新しいブックを保存
    wbNew.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    wbNew.Close SaveChanges:=False
    
    MsgBox "抽出結果を新しいブックに保存しました。" & vbCrLf & savePath, vbInformation
End Sub

✅ コードの詳細解説

・AutoFilterの設定

wsSrc.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=">=100000"

• Field:=3 は「3列目（C列）」を対象にしています。

• Criteria1:=">=100000" は「10万円以上」という条件。
  この部分を変更することで、任意の条件に柔軟に対応できます。
  参考：【VBA】AutoFilterの複数条件を設定する方法｜AND・ORを自在に操る実務向け活用術

・SpecialCellsで可視セルを取得

Set rngVisible = wsSrc.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)

• SpecialCells(xlCellTypeVisible) は、フィルター後に「表示されている行だけ」を取得します。

• 抽出結果が1件もない場合はエラーになるため、On Error Resume Next で回避しています。
  参考：【VBA】条件に一致するセルを複数取得する方法｜Find・For Each・SpecialCells

・保存パスの設定

savePath = ThisWorkbook.Path & "\抽出結果_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"

• ThisWorkbook.Path：元ファイルと同じフォルダに保存

• Format(Now, "yyyymmdd_hhmmss")：現在時刻を付与して重複防止
  これにより、毎回異なるファイル名で安全に保存できます。

✅ 条件を動的に変更できる応用マクロ

次に紹介するのは、条件をユーザーが自由に入力できるようにしたマクロです。
毎回フィルター条件が異なる実務に最適です。

・動的フィルター＆保存のVBA

Sub SaveFilteredDataByUserInput()
    Dim wsSrc As Worksheet
    Dim wbNew As Workbook
    Dim rngVisible As Range
    Dim savePath As String
    Dim minValue As Double
    
    Set wsSrc = Worksheets("売上データ")
    
    'ユーザーに条件を入力させる
    minValue = InputBox("抽出する最低売上金額を入力してください。", "条件入力", 100000)
    If minValue = 0 Then Exit Sub
    
    wsSrc.AutoFilterMode = False
    wsSrc.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=">=" & minValue
    
    On Error Resume Next
    Set rngVisible = wsSrc.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rngVisible Is Nothing Then
        MsgBox "該当データがありません。", vbInformation
        Exit Sub
    End If
    
    Set wbNew = Workbooks.Add
    rngVisible.Copy Destination:=wbNew.Sheets(1).Range("A1")
    
    savePath = ThisWorkbook.Path & "\抽出結果_" & minValue & "以上_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    wbNew.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    wbNew.Close SaveChanges:=False
    
    MsgBox "売上金額 " & minValue & "以上のデータを保存しました。" & vbCrLf & savePath, vbInformation
End Sub

・ポイント

• InputBoxでユーザーに条件を入力させる

• 変数を利用してCriteria1を動的に設定

• 保存ファイル名にも条件を付与し、管理しやすく

この形にしておくと、担当者や支店ごとに異なる抽出条件をすぐに使い分けることができます。

参考：Excel VBA:日付を含むファイル名で自動保存する方法

✅ 見出しを除いて抽出データのみを保存したい場合

通常のコピーでは、フィルターのヘッダー行も含まれます。
もしヘッダーを省いてデータのみを保存したい場合は、OffsetとResizeを使用します。

・ヘッダーを除外して保存するVBA

Sub SaveFilteredDataWithoutHeader()
    Dim wsSrc As Worksheet
    Dim wbNew As Workbook
    Dim rngVisible As Range
    Dim savePath As String
    
    Set wsSrc = Worksheets("売上データ")
    wsSrc.AutoFilterMode = False
    wsSrc.Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=">=100000"
    
    On Error Resume Next
    Set rngVisible = wsSrc.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rngVisible Is Nothing Then
        MsgBox "該当データがありません。", vbInformation
        Exit Sub
    End If
    
    Set wbNew = Workbooks.Add
    rngVisible.Offset(1, 0).Resize(rngVisible.Rows.Count - 1).Copy Destination:=wbNew.Sheets(1).Range("A1")
    
    savePath = ThisWorkbook.Path & "\抽出結果_データのみ_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    wbNew.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    wbNew.Close SaveChanges:=False
    
    MsgBox "ヘッダーを除いた抽出結果を新しいブックに保存しました。", vbInformation
End Sub

✅ エラー対策・安全設計のポイント

フィルター＋コピー＋保存の処理では、状況によって以下のようなエラーが発生することがあります。
安全に動作させるためには、いくつかの対策を組み込むのが重要です。

・フィルター残りによる誤抽出を防ぐ

If wsSrc.AutoFilterMode Then wsSrc.AutoFilterMode = False

毎回フィルターをリセットしておくことで、以前の条件が残るトラブルを防げます。

・抽出結果がない場合のエラー回避

If rngVisible Is Nothing Then
    MsgBox "該当データがありません。", vbInformation
    Exit Sub
End If

SpecialCells(xlCellTypeVisible)は該当データがないとエラーを返すため、
必ずNothing判定を入れてマクロが強制終了しないようにします。

・保存パスの指定に失敗しないための工夫

保存場所が未設定のブックではThisWorkbook.Pathが空になります。
その場合はApplication.GetSaveAsFilenameを使うと安心です。

If ThisWorkbook.Path = "" Then
    savePath = Application.GetSaveAsFilename(FileFilter:="Excelファイル (*.xlsx), *.xlsx")
Else
    savePath = ThisWorkbook.Path & "\抽出結果_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
End If

✅ 応用例：部署ごとにフィルターして複数ブックを自動生成

実務で特に便利なのが、「特定の列（例：支店名）」でフィルターして、
支店ごとに新しいファイルを自動で保存するマクロです。

・支店別ブック自動生成マクロ

Sub ExportFilteredDataByBranch()
    Dim wsSrc As Worksheet
    Dim rng As Range, c As Range
    Dim dict As Object
    Dim branch As String
    Dim wbNew As Workbook
    Dim savePath As String
    
    Set wsSrc = Worksheets("売上データ")
    Set rng = wsSrc.Range("B2:B" & wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row) 'B列に支店名
    Set dict = CreateObject("Scripting.Dictionary")
    
    '支店名を重複なしで取得
    For Each c In rng
        If Not dict.exists(c.Value) And c.Value <> "" Then
            dict.Add c.Value, Nothing
        End If
    Next c
    
    '各支店ごとに抽出→保存
    For Each branch In dict.keys
        wsSrc.AutoFilterMode = False
        wsSrc.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=branch
        
        On Error Resume Next
        Set rng = wsSrc.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rng Is Nothing Then
            Set wbNew = Workbooks.Add
            rng.Copy Destination:=wbNew.Sheets(1).Range("A1")
            
            savePath = ThisWorkbook.Path & "\" & branch & "_売上_" & Format(Now, "yyyymmdd") & ".xlsx"
            wbNew.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
            wbNew.Close SaveChanges:=False
        End If
    Next branch
    
    wsSrc.AutoFilterMode = False
    MsgBox "支店別ファイルの作成が完了しました。", vbInformation
End Sub

・実務での効果

• 支店別・担当者別ファイルの自動生成

• 配布用ブックを一括で出力

• 日次・週次の定期レポート化も容易

このような形にしておくと、人手を介さずに複数ファイル出力を完全自動化できます。

✅ まとめ：VBAでフィルター結果を自動保存して業務を効率化しよう

最後に本記事の要点を整理します。

• AutoFilterで条件抽出 → SpecialCellsで可視セル取得

• 新しいブックをWorkbooks.Addで生成し、抽出結果をコピー

• SaveAsでファイルを保存（日時・条件名を付与）

• Offsetを使えばヘッダーを除外可能

• 安全設計としてAutoFilterMode解除とNothing判定を忘れずに

• 応用で「支店別・担当者別」自動ブック出力も可能

VBAによるフィルター結果の保存は、単なる便利テクニックではなく、
日報作成・支店配布・顧客別報告などの業務を根本から効率化する手段です。

一度仕組みを作っておけば、数百行のデータ処理も数秒で完了。
あなたの業務に合わせてぜひカスタマイズし、毎日のExcel作業を“クリック一つ”で自動化しましょう。