When you keep adding sheets to a manual or similar document in Excel, have you noticed the file itself getting heavier, or Excel becoming sluggish? For situations like that, I built a macro that splits each sheet of an Excel file into its own file, and I'll explain it here. [Download the sample Excel file](https://github.com/atman-33/template-excel-vba/tree/main/Excel%E3%82%B7%E3%83%BC%E3%83%88%E3%82%92%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%81%AB%E5%88%87%E3%82%8A%E5%87%BA%E3%81%97%E5%87%BA%E5%8A%9B) ## Overview The macro's features are as follows: - Run the macro (click a button) - Select the Excel file whose sheets you want to split into files - Each sheet of the selected file is extracted and saved as its own Excel file （in the same folder as the selected file） - A list of links to the extracted files is generated in the macro's own Excel file ## Package Structure The structure inside the Excel macro is as follows. ```text Excelの各シートをファイルに切り出し.xlsm | 標準モジュール |-Main |-ModuleHelper |-ModuleSheetToFile ``` ## Source Code Explanation This is the source code for the Excel VBA (macro) processing. ### ①Main ```vb Option Explicit ' メイン処理 Public Sub Main() ' 描画処理、自動更新などを停止 Focus True ' Excelシートをファイルに保存する処理 GetOpenFileSheetstSave ' 描画処理、自動更新などを再開 Focus False End Sub ``` I prepared a `Focus` function that runs around the main `GetOpenFileSheetsSave` function. This `Focus` function stops Excel's screen rendering and automatic updates, which shortens the macro's execution time. ___ ### ①ModuleHelper These are the functions used this time. ```vb Option Explicit ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 画面描画などを停止して実行を早くする。 ' note : Focus = True -> 描画停止、イベント抑制、手動計算 ' Focus = False -> 描画再開、イベント監視再開、自動計算 ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Public Sub Focus(ByVal Flag As Boolean) With Application .EnableEvents = Not Flag .ScreenUpdating = Not Flag .Calculation = IIf(Flag, xlCalculationManual, xlCalculationAutomatic) End With End Sub ``` ___ ### ②ModuleSheetToFile Key points and supplementary notes are written as comments in the code. ```vb Option Explicit ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 選択したExcelファイルの各シートをファイルに切り出し ' note : ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Public Sub GetOpenFileSheetstSave() Dim openFilePath As String Dim saveFolderPath As String openFilePath = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xlsx") If openFilePath <> "False" Then ' ファイルが選択された場合 saveFolderPath = GetFileFolderPath(openFilePath) SheetsSave openFilePath, saveFolderPath MsgBox "処理を完了しました" Else MsgBox "キャンセルされました" End If End Sub ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 各シートをファイルに切り出し ' note : 引数の excelPath, saveFolder はフルパス ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Public Sub SheetsSave(excelPath As String, saveFolderPath As String) Dim wb As Workbook Dim sheet As Object Dim linkListSheetRow As Long Dim linkListSheetName As String linkListSheetRow = 1 linkListSheetName = "__LinkList__" ' ファイル切り出し先リンク一覧のシートを作成 CreateSheet linkListSheetName ' ブックを開く Set wb = Workbooks.Open(excelPath) For Each sheet In wb.Worksheets ' 事前に同名のファイルを削除 KillFile saveFolderPath & "\" & sheet.name & ".xlsx" sheet.Copy ActiveWorkbook.SaveAs saveFolderPath & "\" & sheet.name ActiveWorkbook.Close ' ファイル切り出し先リンク一覧へ追加 ThisWorkbook.Worksheets(linkListSheetName).Cells(linkListSheetRow, 1).Value = sheet.name ThisWorkbook.Worksheets(linkListSheetName).Cells(linkListSheetRow, 2).Value = saveFolderPath & "\" & sheet.name & ".xlsx" ' ハイパーリンク追加（対象のシートをActiveにする必要あり） ThisWorkbook.Worksheets(linkListSheetName).Activate ActiveSheet.Hyperlinks.Add Anchor:=Cells(linkListSheetRow, 2), Address:=Cells(linkListSheetRow, 2).Value linkListSheetRow = linkListSheetRow + 1 Next sheet ' ブックを閉じる Application.DisplayAlerts = False '確認メッセージを出さない wb.Close savechanges:=False '保存せずに閉じる Application.DisplayAlerts = True '確認メッセージを出す End Sub ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : シートを追加作成 ' note : 作成するシートは最後尾に追加 ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Private Sub CreateSheet(sheetName As String) If SheetExists(sheetName) = False Then ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ActiveSheet.name = sheetName End If End Sub ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 指定したファイルのフォルダパスを取得 ' note : ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Private Function GetFileFolderPath(filePath As String) As String Dim pathName As String Dim fileName As String fileName = Dir(filePath) pathName = Replace(filePath, fileName, "") pathName = CutRight(pathName, 1) Debug.Print pathName & vbCrLf & fileName GetFileFolderPath = pathName End Function ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 文字列の右側から指定文字数削除 ' note : 引数１：対象の文字列、引数２：削除文字数、戻り値：削除後の文字列 ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Private Function CutRight(s, i As Long) As String Dim iLen As Long ' 文字列長 ' 文字列ではない場合 If VarType(s) <> vbString Then Exit Function End If iLen = Len(s) ' 文字列長より指定文字数が大きい場合 If iLen < i Then Exit Function End If ' 指定文字数を削除して返す CutRight = Left(s, iLen - i) End Function ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : 対象のシートが存在するか判定 ' note : ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Private Function SheetExists(sheetName As String) As Boolean Dim wb As Workbook Dim ws As Worksheet Set wb = ThisWorkbook On Error Resume Next Set ws = wb.Worksheets(sheetName) On Error GoTo 0 SheetExists = Not ws Is Nothing End Function ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ' brief : ファイルを削除 ' note : ' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- Private Sub KillFile(filePath As String) Dim strFilePath As String strFilePath = filePath 'ファイルパス If Dir(strFilePath) <> "" Then ' ファイルが存在する Debug.Print "ファイル削除開始：" & strFilePath Kill strFilePath Else ' ファイルが存在しない Debug.Print "ファイルは存在しません：" & strFilePath End If End Sub ``` Extracting each sheet of an Excel file into its own saved file is a simple feature, but this turned out to be a good example with a few points worth watching out for. Since this time's functions are general-purpose, you might find it useful to change the access modifier of the functions from private to public and reuse them. That's it!