【マクロ・VBA　コード・ファイルダウンロード可】複数のSheetを複数bookに変換するマクロ

Sub 読込データ格納用フォルダ作成()

'変数////////////////////////////////////////////////////
Dim FSO As Object 'ファイルシステムオブジェクト用変数

Set FSO = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

'読込データ格納用フォルダ作成/////////////////////////////////////////////////////

If FSO.FolderExists(wb.Path & "￥" & "読込データ格納用フォルダ") = False Then '読込データ格納用フォルダがないとき
    
    FSO.CreateFolder wb.Path & "￥" & "読込データ格納用フォルダ" 'フォルダを作成
    
    MsgBox "読込データ格納用フォルダを作成しました" & vbCrLf & vbCrLf & "読込たいデータを「読込データ格納用フォルダ」に入れてください"
    
Else '読込データ格納用フォルダがあった場合
    MsgBox "読込データ格納用フォルダは既に作成されてます"
End If

Set FSO = Nothing
End Sub

Sub 作成book格納用フォルダ作成()

'変数////////////////////////////////////////////////////
Dim FSO As Object 'ファイルシステムオブジェクト用変数

Set FSO = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

'作成book格納用フォルダ作成/////////////////////////////////////////////////////

If FSO.FolderExists(wb.Path & "￥" & "作成book格納用フォルダ") = False Then '作成book格納用フォルダがないとき
    
    FSO.CreateFolder wb.Path & "￥" & "作成book格納用フォルダ" 'フォルダを作成
    
    MsgBox "作成book格納用フォルダを作成しました" & vbCrLf & vbCrLf & "Sheetから変換されたbookは「作成book格納用フォルダ」に出力されます"
    
Else '作成book格納用フォルダがあった場合
    MsgBox "作成book格納用フォルダは既に作成されてます"
End If

Set FSO = Nothing
End Sub

Sub 既存Sheetの削除()

'変数////////////////////////////////////////////////////
Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

Dim ws_メイン As Worksheet: Set ws_メイン = wb.Sheets("メイン") '集計データSheet用変数

Dim ws As Worksheet 'カウンター変数用

'既存Sheetの削除////////////////////////////////////////////////
For Each ws In wb.Sheets 'Sheetのループ処理

    If ws.Name <> "メイン" Then 'Sheet名が「メイン」出ないとき
    
        Application.DisplayAlerts = False '警告表示の非表示設定
        
            ws.Delete '該当Sheetを削除
        
        Application.DisplayAlerts = True '警告表示の表示設定
    
    End If

Next

End Sub

Sub 複数のSheetを複数bookに変換するマクロ()

Application.ScreenUpdating = False '画面の固定

'変数////////////////////////////////////////////////////

Dim FSO As Object 'ファイルシステムオブジェクト用変数

Set FSO = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

Dim i, j 'カウンター変数

Dim ws As Worksheet 'Sheet用カウンター変数

Dim r_wb As Workbook '読込データ用book変数

Dim r_path As String: r_path = wb.Path & "￥" & "読込データ格納用フォルダ" '読込データ格納用フォルダパス用変数

Dim out_path As String: out_path = wb.Path & "￥" & "作成book格納用フォルダ" '作成book格納用フォルダパス用変数

Dim n_file As String: n_file = Dir(r_path & "￥*")

Dim r_ary '読込データ用配列

Dim out_sheetname As String 'book変換するSheet名用変数

Dim out_wb As Workbook '変換したbook用変数

'ファイルを開く→Sheetをコピー///////////////////////////////////////////////

Do While n_file <> ""
                
    Set r_wb = Workbooks.Open(r_path & "￥" & n_file) 'ファイルを開く
    
    For Each ws In r_wb.Sheets
    
        ws.Copy After:=wb.Sheets(wb.Sheets.Count)
    
    Next
    
    Application.DisplayAlerts = False '警告表示の非表示設定
    
    r_wb.Close 'データを閉じる
    
    Application.DisplayAlerts = True '警告表示の表示設定
    
    
    n_file = Dir() '次のファイル名を取得

Loop

'配列に代入→book作成book名はSheet→貼付け////////////////
Application.DisplayAlerts = False '警告表示の非表示設定

For Each ws In wb.Sheets 'シートのループ処理
    
    If ws.Name <> "メイン" Then 'メインSheet以外の時
    
        out_sheetname = ws.Name 'sheet名をout_sheetnameに代入
        
        Set out_wb = Workbooks.Add '新規book作成
            
        ws.Copy before:=out_wb.Sheets(1)  'Sheetをコピー
            
        out_wb.SaveAs out_path & "￥" & out_sheetname '作成book格納用フォルダにSheet名をbook名にして名前付き保存
        
        out_wb.Close '作成したbookを閉じる
    
    End If

Next
    
Application.DisplayAlerts = True '警告表示の表示設定
    
Application.ScreenUpdating = True '画面の固定解除
 
MsgBox "変換完了"

End Sub