1つのブックからシートごとにブックを分割する

なにかと便利なので置いておきます

splitSheet

Option Explicit
'''
' 1つのブックからシートごとにブックを分割する
'''
Sub copyBook()
    ' ループ対象シート
    Dim objSheet As Worksheet
    ' 出力先ブック
    Dim wb As Workbook
    ' 出力先シート
    Dim ws As Worksheet
    ' 分割対象ブック
    Dim wob As Workbook
    '分割対象ファイルパス
    Dim fname As String

    ' マクロ高速化開始
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    ' 分割対象ブックを選択
    fname = Application.GetOpenFilename(Filefilter:="Excelブック,*.xlsx,Excelマクロ,*.xlsm")
    If fname <> "False" Then
    
        ' 分割対象のブックを読み取り専用で開く
        Set wob = Workbooks.Open(fname, ReadOnly:=True)
        
        ' 貼り付け元ブックの全シートを 1 つずつループして処理する
        For Each objSheet In wob.Worksheets
    
            ' 貼り付け先ワークブックを作成
            Set wb = Workbooks.Add
            ' 貼り付け先のシートを取得
            Set ws = wb.Sheets(wb.Sheets.Count)
            '名前同じにしたいなら以下の'外す
             ws.Name = objSheet.Name
            
            ' 貼り付け元の全ての値を貼り付け先ワークシートに張り付ける(値だけ)
            ws.Range(objSheet.UsedRange.Address).Value = objSheet.UsedRange.Value
            
            ' ワークブックの保存(元ブック名 + シート名)
            wb.SaveAs wob.Path & "\" & Replace(Replace(wob.Name, ".xlsx", ""), ".xlsm", "") & "_" & ws.Name & ".xlsx"
            wb.Close
            ' ワークシートの開放
            Set ws = Nothing
            Set wb = Nothing
        Next
        
        ' 分割対象ブックを閉じる
        wob.Close False
        
        MsgBox "分割が完了しました"
    Else
        MsgBox "中止しました"
    End If
    
    ' マクロ高速化終了
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub