VBA | Splitting Each Sheet of an Excel File into Separate Files

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

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.

Excelの各シートをファイルに切り出し.xlsm
|
標準モジュール
|-Main
|-ModuleHelper
|-ModuleSheetToFile

Source Code Explanation

This is the source code for the Excel VBA (macro) processing.

①Main

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.

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.

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!