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

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

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

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

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