複数のシートを個別のブックに分解して保存（Excel　VBA）

いつもありがとうございます。なかまさです。
少しばかりnoteをお休みしておりましたが、ここからまた頑張っていきたいと思います。

ということで、今回はExcel VBAの記事で進めていきたいと思います。

こんなことを自動化します。

突然ですが、こんなことで困ったことないですか？

一つのエクセルに複数のシートが存在している時って無いですか？
（例えば、支店ごとにシートを分けて売上表を作っているみたいな・・・）

そして、時としてそれぞれのシートを一つずつのエクセルファイルにしたい時もあると思うんです。

シートのコピペを手作業でやっていて、困っている人もいるんじゃないかと思いましたので、複数シートを自動で分割するVBAを作ってみました。

使い方

今回はVBAを仕込んだエクセルを用意したのでご活用ください。

シート分割.xlsm

22.8 KB

ファイルダウンロードについて

ダウンロード

※マクロの保護を外して使用してください。

使い方はいたってシンプルで、シート「Menu」内に設置されたボタンを押すとダイアログボックスが表示されます。

1つ目の表示・・・複数のシートが入ったExcelを選択
2つ目の表示・・・保存先のフォルダを選択

1つ目で選んだエクセルファイルの各シートを、2つ目で選んだフォルダに保存するという感じです。

※データは、「シート名」.xlsxで保存されます。
※ファイル名に使用できない文字を使用している場合はエラーになるのでご注意ください。（例えば「/」とか）
※あくまで自己責任でご活用ください。

プログラム内容

書き方が汚いとか、エラー処理適当とかはご容赦ください。笑
何分、独学でやっておりますので・・・

Sub separate_sheets() '指定したエクセルブック内のシートを個別のエクセルブックとして保存します。
        
    Dim File_path As String
    Dim Save_Path As String
    Dim i As Long
    
    Dim wb As Workbook 'シートが複数格納されたエクセルブック
    Dim wb2 As Workbook '分割後のシートを保存するエクセルブック
        
    '分割するエクセルを選択するダイアログを表示
    File_path = GetSelectedFilePath()
    
    'ファイルが選択されていない場合は処理終了
    If File_path = "" Or File_path = "False" Then
        MsgBox "エクセルファイルが選択されていません。"
        Exit Sub
    End If
    
    '分割後のデータを保存するフォルダを選択するダイアログを表示
    Save_Path = GetSelectedFolderPath()
    
    'フォルダが選択されていない場合は処理終了
    If Save_Path = "" Or Save_Path = "False" Then
        MsgBox "保存先のフォルダが選択されていません。"
        Exit Sub
    End If
      
    '選択したエクセルファイルを開く
    Set wb = Workbooks.Open(File_path)
    
    'シートが存在しない場合は処理終了
    If wb.Worksheets.Count = 0 Then
        MsgBox "このエクセルにはシートが存在しません。"
    End If
        
    '警告を表示しない
    Application.DisplayAlerts = False
    
    '各シートを新規ブックにコピーし保存する
    For i = 1 To wb.Worksheets.Count
        Set wb2 = Workbooks.Add
        wb.Worksheets(i).Copy After:=wb2.Sheets(wb2.Sheets.Count)
        wb2.Worksheets(1).Delete
        wb2.SaveAs Save_Path & "\" & wb.Worksheets(i).Name & ".xlsx"
        wb2.Close
    Next i
    
    'エクセルを閉じる
    wb.Close False
    
    '警告を表示する
    Application.DisplayAlerts = True
    MsgBox ("処理が完了しました！")
    
    
End Sub

次がファイルやフォルダを選択するダイアログを表示するプログラムです。
（ほぼChat-Gptが作ってくれましたが・・・笑）

Function GetSelectedFilePath() As String
    Dim fileDialog As fileDialog
    Dim selectedPath As String
    
    ' ファイルダイアログのインスタンスを作成します
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    
    With fileDialog
        .Title = "分割するエクセルファイルを選択してください" ' ダイアログのタイトルを設定します
        .Filters.Clear ' 既存のフィルタをクリアします
        .Filters.Add "Excelファイル", "*.xlsx; *.xls; *.xlsm" ' フィルタを追加します
        
        ' ダイアログを表示します
        If .Show = -1 Then ' ユーザーがファイルを選択した場合
            selectedPath = .SelectedItems(1) ' 選択されたファイルのパスを取得します
        Else ' ユーザーがキャンセルした場合
            selectedPath = ""
        End If
    End With
    
    ' オブジェクトを解放します
    Set fileDialog = Nothing
    
    ' 選択されたファイルのパスを返します
    GetSelectedFilePath = selectedPath
End Function

Function GetSelectedFolderPath() As String
    Dim folderDialog As fileDialog
    Dim selectedFolderPath As String
    
    ' フォルダ選択ダイアログのインスタンスを作成します
    Set folderDialog = Application.fileDialog(msoFileDialogFolderPicker)
    
    With folderDialog
        .Title = "保存先のフォルダを選択してください" ' ダイアログのタイトルを設定します
        
        ' ダイアログを表示します
        If .Show = -1 Then ' ユーザーがフォルダを選択した場合
            selectedFolderPath = .SelectedItems(1) ' 選択されたフォルダのパスを取得します
        Else ' ユーザーがキャンセルした場合
            selectedFolderPath = ""
        End If
    End With
    
    ' オブジェクトを解放します
    Set folderDialog = Nothing
    
    ' 選択されたフォルダのパスを返します
    GetSelectedFolderPath = selectedFolderPath
End Function

長くなってしまいましたが、中身はこんな感じです。

最後に

どうでしょうか、参考になりましたでしょうか？
手作業だとめちゃくちゃ時間がかかると思うので、少しでも役立っていれば嬉しいです。

こんな作業に困っているということがあれば教えてほしいです！色んなことにチャレンジしてみたいので、、、笑

今回の記事はここまで！ではまた！