Excel VBA シートを個別のブックとして保存するマクロ個人用マクロブックに組み込めるよ

はじめに

Excelで、たとえば「1日」～「31日」までの31個など、多数のシートが1つのブック内にあるとする。

それらはシート分けするのでなく「1日.xlsx」「2日.xlsx」・・・・・・「31日.xlsx」と、Excelブックに分ける形で保存したいということはないだろうか。

私なんかはそれが良くあるんだけどね。

「1日.xlsx」ファイルには「1日」シートだけ
「2日.xlsx」ファイルには「2日」シートだけ

という感じで、1つのブックには1つのシートだけがある状態で保存しておくわけね。

これは、シートが多くなると手作業ではやっていられないので、今回はそれを簡単に実行するマクロについて書いていく。
あちこちで類似のマクロは紹介されているはずだけどね。

そもそも、あんまり1つのExcelブックの中に、シートを増やしすぎるものではない。

シート数を増やしすぎるデメリット

ファイルサイズが重くなる。
目的のシートを探すのが大変。シートを名前とかで検索するのは、通常機能ではできないし。
これ以上更新を加えたくない状態のシートについても、更新が加わったかどうか判別しにくくなる。

といったデメリットもあるしね。
シートを増やすのは主に、シート間に相互に計算式とかで繋がりがある場合にするべき。

考えなしにシートを増やしすぎるのでなく、Excelの個別ブックとして分けて保存することを、まず考えよう。

マクロの動作イメージ

それでは今回のマクロの動作イメージ。
Excelブックを開いた状態からマクロを起動すると、フォルダを選択するダイアログが出てくる。

Excelの各シートをブックとして分けて保存するわけだけど、その保存フォルダを指定する(初期表示としては、そのExcelブックの保存されているフォルダが表示される)。

するとそのフォルダに、現在時刻(秒単位)のフォルダが新規作成され、そこに各Excelブックが新規保存される。
マクロの実行が終わったら、そのフォルダが自動的に開かれ表示される。

マクロのソースコード

それでは今回のマクロのソースコード。

Sub saveEachSheetsToBooks()
'各シートをブックとして個別保存する
    Dim mainWb      As Workbook
    Dim eachWb      As Workbook
    Dim eachWs      As Worksheet
    Dim myPath      As String
    Dim wsName      As String
    
    Set mainWb = ActiveWorkbook
    myPath = mainWb.Path '元のExcelファイルの保存場所
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = myPath '元のExcelファイルの保存場所を初期フォルダに指定
        If Not .Show Then Exit Sub
        myPath = .SelectedItems(1)
    End With
    
    
    Call appSet
    
    '保存場所。現在時刻のフォルダを新規作成する。
    myPath = myPath ＆ "\" ＆ Format$(Now, "yyyy年mm月dd日hh時mm分ss秒") ＆ "\"
    MkDir myPath
    
    On Error Resume Next
    
    For Each eachWs In mainWb.Worksheets
        wsName = eachWs.Name
        eachWs.Copy '新規ブックにコピー
        
        Set eachWb = ActiveWorkbook
        Application.Calculation = xlCalculationAutomatic '保存のため自動計算に戻しておく
        
        '*********保存形式を、下記の3つのうちから選んでおく。*********
'        eachWb.SaveAs myPath ＆ wsName ＆ ".xls", FileFormat:=xlWorkbookNormal'Excel2003までの形式で保存する場合はこちら
'        eachWb.SaveAs myPath ＆ wsName ＆ ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Excel2007以降(マクロ有り・無しどちらも対応可)で保存する場合はこちら
        eachWb.SaveAs myPath ＆ wsName ＆ ".xlsx", FileFormat:=xlOpenXMLWorkbook 'Excel2007以降(マクロ無し)で保存
        '*********保存形式を、上記の3つのうちから選んでおく。*********
        
        eachWb.Close saveChanges:=False
        Application.Calculation = xlCalculationManual '手動計算に再セット
    Next eachWs
    
    Call appReset
 
    Shell "C:\Windows\Explorer.exe " ＆ myPath, vbNormalFocus '保存したフォルダを開く
    MsgBox "終了しました。", vbInformation, "処理終了"
End Sub
 
Sub appSet()
'マクロ処理中に、描画など余計なものを省略して高速化
    With Application
        .ScreenUpdating = False '描画を省略
        .Calculation = xlCalculationManual '手動計算
        .DisplayAlerts = False '警告を省略。
'        .EnableEvents = False 'DisplayAlertsよりこちらを設定した方が良いのかな？
    End With
End Sub
 
Sub appReset()
'描画などの設定をリセット
    With Application
        .ScreenUpdating = True '描画する
        .Calculation = xlCalculationAutomatic '自動計算
        .DisplayAlerts = True '警告を行う
    End With
End Sub