MENU
ブラック企業から転職して年収UPした理系エンジニア20代転職2回の失敗と成功
非プログラマーでもできる！業務の自動化
  1. ホーム
  2. PythonとVBAで業務の自動化
  3. 【Excel配布】自動ですべてのシートを Excelブックで保存する

【Excel配布】自動ですべてのシートを Excelブックで保存する

PythonとVBAで業務の自動化
当ページのリンクの一部に広告が含まれています。
アイコン

各シートを分割してExcel保存

1 ファイル 18.93 KB
ダウンロード

「Excelのシートを分割して、ぞれぞれを新しいExcelブックとして保存したい」

いちいちシートをコピーして、名前をつけて保存するのは面倒。

でも、そんな面倒な作業もExcelのVBAマクロを使えば、自動で処理できます。

この記事では

【Excelのシートごとに新しいExcelブックとして保存】するVBAのコードを解説しています。

パソコン［最強］時短仕事術 超速で仕事するテクニック
技術評論社
➢ Amazonのレビューを見る

ボタン1つで【Excelのシートごとに新しいExcelブックとして保存】の処理ができる、Excelシートを無料配布。

アイコン

各シートを分割してExcel保存

1 ファイル 18.93 KB
ダウンロード
目次

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…直接入力

以下のコードを実行すると、対象のExcelのすべてのシートを新しいブックとして保存します。

新しいブックの名前はシート名になります。

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…直接入力

  • Excelの更新停止
  • エラーハンドリング
  • 完了メッセージ
  • 変数の宣言
  • エラーハンドリングの開始
  • Excelの更新停止
  • ブックパスの指定
  • ブックの開始
Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = "C:\Path\To\Your\Workbook.xlsx"
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
End Sub

対象のExceのパスlは、targetWorkbookPath に入力してください。

    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = "C:\Path\To\Your\Workbook.xlsx"
パソコン［最強］時短仕事術 超速で仕事するテクニック
技術評論社
➢ Amazonのレビューを見る

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…セル入力

以下のコードを実行すると、対象のExcelのすべてのシートを新しいブックとして保存します。

新しいブックの名前はシート名になります。

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…セル入力

  • Excelの更新停止
  • エラーハンドリング
  • 完了メッセージ
  • 変数の宣言
  • エラーハンドリングの開始
  • Excelの更新停止
  • ブックパスの指定
  • ブックの開始
  • パス取得
  • ワークシートループの開始
Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
End Sub

対象のExcelのパスは、処理するExcelのC2セルに入力してください。

Excelのブック内にあるすべてのシートを

別のExcelブックとして保存できます。

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…配布Excel

配布している処理Excelのコードには、処理速度向上のためにExcelの更新停止と、エラーハンドリングと処理が完了したらメッセージを表示するコードを追加しています。

【Excelのシートごとに新しいExcelブックとして保存】するVBAコード…配布Excel

  • Excelの更新停止
  • エラーハンドリング
  • 完了メッセージ
  • 変数の宣言
  • エラーハンドリングの開始
  • Excelの更新停止
  • ブックパスの指定
  • ブックの開始
  • パス取得
  • ワークシートループの開始
  • 新しいブックの作成
  • シートのコピー
  • 警告メッセージの無効化
  • シート削除ループの開始
Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' Excelの更新を停止
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ' 完了メッセージを表示
    MsgBox "完了しました", vbInformation

    Exit Sub

ErrorHandler:
    ' エラーメッセージを表示
    MsgBox "エラーが発生しました " & Err.Description, vbCritical
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Excelの更新停止

Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' Excelの更新を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

エラーハンドリング

Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' Excelの更新を停止
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Exit Sub

ErrorHandler:
    ' エラーメッセージを表示
    MsgBox "An error occurred: " & Err.Description, vbCritical
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

完了メッセージ

Sub SaveSheetsAsNewBooks()

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim targetWb As Workbook
    Dim path As String
    Dim name As String
    Dim targetWorkbookPath As String
    
    ' Excelの更新を停止
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 対象となるブックのフルパスを指定
    targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value
    
    ' 対象のブックを開く
    Set targetWb = Workbooks.Open(targetWorkbookPath)
    
    ' 対象のブックのパスを取得
    path = targetWb.Path & "\"
    
    ' 対象のブックのすべてのワークシートについてループ
    For Each ws In targetWb.Sheets
    
        ' 新しいブックを作成
        Set wb = Application.Workbooks.Add
        
        ' ワークシートを新しいブックにコピー
        ws.Copy Before:=wb.Sheets(1)
        
        ' コピーしたシート以外を削除
        Application.DisplayAlerts = False
        While wb.Sheets.Count > 1
            wb.Sheets(wb.Sheets.Count).Delete
        Wend
        Application.DisplayAlerts = True
        
        ' 新しいブックを保存
        name = ws.Name
        wb.SaveAs Filename:=path & name & ".xlsx"
        wb.Close SaveChanges:=False
    
    Next ws
    
    ' 対象のブックを閉じる
    targetWb.Close SaveChanges:=False
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ' 完了メッセージを表示
    MsgBox "完了しました", vbInformation

    Exit Sub

ErrorHandler:
    ' エラーメッセージを表示
    MsgBox "エラーが発生しました " & Err.Description, vbCritical
    
    ' Excelの更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
パソコン［最強］時短仕事術 超速で仕事するテクニック
技術評論社
➢ Amazonのレビューを見る
アイコン

各シートを分割してExcel保存

1 ファイル 18.93 KB
ダウンロード

【Excelのシートごとに新しいExcelブックとして保存】するVBAコードの解説

以下にコードの解説を行います。

【Excelのシートごとに新しいExcelブックとして保存】するVBAコードの解説

  • 変数の宣言
  • エラーハンドリングの開始
  • Excelの更新停止
  • ブックパスの指定
  • ブックの開始
  • パス取得
  • ワークシートループの開始
  • 新しいブックの作成
  • シートのコピー
  • 警告メッセージの無効化
  • シート削除ループの開始
  • シートの削除
  • 警告メッセージの有効化
  • ブックの保存と閉じる

変数の宣言

Worksheet、Workbook、およびString型の変数を定義しています。

Dim ws As Worksheet, wb As Workbook, targetWb As Workbook, path As String, name As String, targetWorkbookPath As String

エラーハンドリングの開始

エラーが発生したときにプログラムがどのように動作するかを指示します。エラーが発生すると、コードの実行は「ErrorHandler」ラベルに移動します。

On Error GoTo ErrorHandler

Excelの更新停止

Excelの画面更新と自動計算を停止します。これにより、処理のパフォーマンスが向上します。

Application.ScreenUpdating = False, Application.Calculation = xlCalculationManual

ブックパスの指定

対象となるExcelブックのパスを指定します。このパスは、現在のブック（ThisWorkbook）の「Sheet1」のセルC2に記述されています。

targetWorkbookPath = ThisWorkbook.Sheets("Sheet1").Range("C2").Value

ブックの開始

指定したパスのブックを開き、それをtargetWbというWorkbookオブジェクトに関連付けます。

Set targetWb = Workbooks.Open(targetWorkbookPath)

パス取得

開いたブックの保存先フォルダ（パス）を取得します。

path = targetWb.Path & "\\"

ワークシートループの開始

開いたブック（targetWb）内の各ワークシートに対してループ処理を行います。

For Each ws In targetWb.Sheets

新しいブックの作成

新しいブックを作成し、それをwbというWorkbookオブジェクトに関連付けます。

Set wb = Application.Workbooks.Add

シートのコピー

現在のループでのワークシート（ws）を新しいブックの最初の位置にコピーします。

ws.Copy Before:=wb.Sheets(1)

警告メッセージの無効化

Excelの警告メッセージを無効にします。これにより、シートを削除するときに表示される警告メッセージをスキップできます。

Application.DisplayAlerts = False

シート削除ループの開始

新しいブックに複数のシートがある場合、それらのシートを削除します。

While wb.Sheets.Count > 1

シートの削除

新しいブックの最後のシートを削除します。

wb.Sheets(wb.Sheets.Count).Delete

警告メッセージの有効化

Excelの警告メッセージを再度有効にします。

Application.DisplayAlerts = True

ブックの保存と閉じる

現在のループでのワークシートの名前を取得し、新しいブックをその名前で保存します。その後、新しいブックを閉じます。

name = ws.Name, wb.SaveAs Filename:=path & name & ".xlsx", wb.Close SaveChanges:=False

まとめ：

面倒な繰り返し作業は、プログラミングで自動化して、業務効率アップ。

パソコン［最強］時短仕事術 超速で仕事するテクニック
技術評論社
➢ Amazonのレビューを見る
アイコン

各シートを分割してExcel保存

1 ファイル 18.93 KB
ダウンロード
PythonとVBAで業務の自動化
Excel
よかったらシェアしてね！
  • URLをコピーしました！
  • URLをコピーしました！

コメント

コメントする

目次