28本目：シートをブックに分割

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：シートをブックに分割

#VBA100本ノック 28本目
個人別のシートを個人別のブックに分けまます。
シート名は"部署_氏名"です。
ブックと同一フォルダに"部署"フォルダを作成し、シート名をブック名にして出力してください。
"部署1_日本 太郎"→"部署1"フォルダに"部署1_日本 太郎.xlsx"
※再実行を考慮
※対象ブックは任意

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック028：シートをブックに分割
Sub シートごとに1ブックに出力して部署別フォルダに保存する()

    Dim wb対象ブック As Workbook: Set wb対象ブック = ThisWorkbook
    
    ' シート名の不備をチェック
    Dim シート As Worksheet
    For Each シート In wb対象ブック.Worksheets
    
        If InStr(シート.Name, "_") = 0 Then
            シート.Activate
            MsgBox "シート名に「_」がないシートがあります。"
            Exit Sub
        End If

    Next
    
    ' 現フォルダを一旦すべてバックアップへ移動
    ' (移動失敗時はそこでExit)
    Dim Path親フォルダ As String: Path親フォルダ = wb対象ブック.Path
    Dim Pathバックアップ As String
    Pathバックアップ = Path親フォルダ _
        & "\バックアップ" & Format(Now(), "yyyymmddhhmmss")
    FSO.CreateFolder Pathバックアップ
    
    For Each シート In wb対象ブック.Worksheets
    
        Dim 部署名 As String: 部署名 = Left文字列まで(シート.Name, "_")
        Dim path既存フォルダ As String
        path既存フォルダ = Path親フォルダ & "\" & 部署名
    
        On Error Resume Next
        If FSO.FolderExists(path既存フォルダ) Then
            FSO.MoveFolder path既存フォルダ, Pathバックアップ & "\" & 部署名
        End If
        
        If Err.Number > 0 Then
            MsgBox 部署名 & "のフォルダをバックアップに移せなかったため処理を中断しました。"
            Exit Sub
        End If
        On Error GoTo 0

    Next

    ' 各シートを新規ブックに出力して保存
    For Each シート In wb対象ブック.Worksheets
    
        部署名 = Left文字列まで(シート.Name, "_")
        Dim path出力フォルダ As String
        path出力フォルダ = Path親フォルダ & "\" & 部署名

        ' 新出部署のフォルダを作成
        If FSO.FolderExists(path出力フォルダ) = False Then
            FSO.CreateFolder path出力フォルダ
        End If
        
        ' ブックを出力して保存
        シート.Copy
        Dim wb出力ブック As Workbook: Set wb出力ブック = ActiveWorkbook
        wb出力ブック.SaveAs path出力フォルダ & "\" & シート.Name & ".xlsx"

        wb出力ブック.Close False
        
    Next

End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

解説

シートを1枚ずつ単独のブックにし、それを保存していく問題でした。

処理自体はかなり単純で、各シートを.Copyで新規ブックにコピーしたあと、
それを単にSaveAsしていけばよい処理です。

WorksheetのCopyメソッドが「引数省略時は新規ブックにコピー」なのは、
かなり便利な仕様なのでしっかり覚えて活用していきましょう。

さてこの問題はメイン処理以上にエラー・ユーザー操作対応が大変です。

「再実行を考慮」ということなので連続実行に耐える必要がありますが、
ちょっと考えるだけでも気にしなければいけないポイントが大量になります。

ただ保存するだけだと「退職者が消されず残る」などの問題があるため、
基本は一度全部消してから再度作り直すのがベストです。

しかし、消してしまうとそれはそれで危険ですので、
今回は「メイン処理の実行前にフォルダごとバックアップに移動」しました。

これをやるにしても、ファイルを出力している途中でエラーが起きると、
作成中のファイルと移動失敗前の既存フォルダが混じって大変なことになるため、

1. まずは部署だけを見て既存フォルダをバックアップへ移動
2. エラーが起きればこの時点で一度止める
3. 無事移動が済んだら実際の出力処理に入る

という手順で実行しています。

ただこれでも「部署がなくなった場合に初期化されない」問題や、
「移動が中途半端に実行されてしまう」問題には対応できていません。

このあたり100%の対応は不可能と思いますので、
実務ではどこで折り合いをつけるか、よく考察してから設計に入りましょう。