Computing Atman
VBA | Excelの各シートをファイルに切り出して分割保存
🐆

VBA | Excelの各シートをファイルに切り出して分割保存

Excel VBA で 各シートを別ファイルに出力する方法

2020/03/15

Excelでマニュアルなど作成していると、シート数が多くなりすぎてファイル自体が重くなったり、Excelの動作が重くなったりすることはないでしょうか?

そのような場合に使えそうな、Excelの各シートをファイルに切り出して分割保存するマクロを作成しましたので説明します。

サンプルのExcelをダウンロード

概要

今回のマクロ機能は、以下の通りです。

  • マクロを実行(ボタン押下)
  • 各シートをファイルに分割したいExcelファイルを選択
  • 選択ファイルの各シートをExcelファイルとして切り出し保存 (選択したファイルと同フォルダ内)
  • マクロ実行Excelファイルに『切り出したファイルのリンク先一覧』を生成

パッケージ構成

Excelマクロ内の構成は下記となります 。

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

ソースコード解説

ExcelのVBA、いわゆるマクロ処理のソースコードとなります。

①Main

Option Explicit
 
' メイン処理
Public Sub Main()
 
    ' 描画処理、自動更新などを停止
    Focus True
 
    ' Excelシートをファイルに保存する処理
    GetOpenFileSheetstSave
 
    ' 描画処理、自動更新などを再開
    Focus False
 
End Sub

メインの GetOpenFileSheetsSave 関数を実行する間に Focus 関数を準備しました。

この Focus 関数でExcelの描画処理、自動更新などを停止しておくことでマクロ実行時間を短縮させます。


①ModuleHelper

今回使用する関数です。

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

ポイントや補足はコード内のコメントに記載しています。

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  : 引数1:対象の文字列、引数2:削除文字数、戻り値:削除後の文字列
' ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
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

Excelの各シートを別ファイルに切り出して保存するというシンプルな機能ですが、注意すべき点もいくつかあった良いサンプルでした。

今回の関数は汎用的にも使えるため、関数のアクセス修飾子を private から public に変更して活用してもらってもよいかと思います。

以上です。