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

この記事から得るもの

WorkSheet名（部署_人名）で、それぞれフォルダ作成（部署）し、個別ファイル（人名）を格納する。

１　今回のお題

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

f:id:bimori466:20201126212255p:plain

少しわかりづらい部分がありそうなので補足します。
"部署_氏名"
この「部署」はいくつもあります。
個人別のブックを部署ごとに振り分けて出力してください。

２　今回のお題の意図

以下のWorkSheet名（部署_人名）があるBookから、
f:id:bimori466:20201126212545p:plain

部署ごとのフォルダを作り、
f:id:bimori466:20201126212722p:plain

該当部署のフォルダに各人のファイルを作成する。
f:id:bimori466:20201126212922p:plain

例えば、売上表などをひとつのBookにまとめているとして、それを部署ごとのフォルダを作成し各人のSheetデータの入ったBookを作成するというものです。

３　回答

私の最初の回答

Sub ノック28本目_1()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim FolderPath As String:  FolderPath = ThisWorkbook.Path & "\28本目\"
Dim FolderName As String


For Each thisSheet In wb.Sheets
    'sheet名が"*_*"の形式でないものを回避
    If thisSheet.Name Like "?*_?*" Then
    
        'フォルダ作成名を取得する
        FolderName = StrConv(Mid(thisSheet.Name, 1, InStr(thisSheet.Name, "_") - 1), vbNarrow)
        
        'フォルダがなければ作成する
        If Dir(FolderPath & FolderName, vbDirectory) = "" Then: MkDir FolderPath & FolderName
        
        'ファイルを作成する(強制上書き)
        Application.DisplayAlerts = False
        Workbooks.Add: ActiveWorkbook.SaveAs Filename:=FolderPath & FolderName & "\" & thisSheet.Name
        ActiveWorkbook.Close
        Application.DisplayAlerts = True
    End If
Next

End Sub

結論から言うと、このコードではお題の意図に応えられていません。
ファイルを作成する処理で、「Workbooks.Add」をしています。つまり、新規Bookを作成しています。なのでデータがないのです。Addした後に、「ActiveWorkbook.SaveAs Filename:=FolderPath & FolderName & "\" & thisSheet.Name」で、ファイルの名前はWorkSheet名で作成できています。しかし、お題の意図はそういうことではありません。
BookにまとめられたSheetのデータで、個別のBookを作るのです。

では、どうすればいいのか。
答えは、「Sheet.Copy」です。

私の最終回答

Sub ノック28本目_2()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim FolderPath As String:  FolderPath = ThisWorkbook.Path & "\28本目\"
Dim FolderName As String

For Each thisSheet In wb.Sheets
    'sheet名が"*_*"の形式でないものを回避
    If thisSheet.Name Like "?*_?*" Then
    
        'フォルダ作成名を取得する
        FolderName = StrConv(Mid(thisSheet.Name, 1, InStr(thisSheet.Name, "_") - 1), vbNarrow)
        
        'フォルダがなければ作成する
        If Dir(FolderPath & FolderName, vbDirectory) = "" Then: MkDir FolderPath & FolderName
        
        'Sheetの表示
        thisSheet.Visible = xlSheetVisible
        
        thisSheet.Copy  'Sheetのデータがコピーされた新規Bookができる
        
        '新規BookにコピーしたSheetを貼り付けて、閉じる。
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=FolderPath & FolderName & "\" & thisSheet.Name
        ActiveWorkbook.Close SaveChanges:=False
        
    End If
Next

End Sub

はじめて知ったのですが、「thisSheet.Copy」を実行するとSheetのデータがコピーされた新規Bookが作成されます。つまり、まとめられたBookのデータの内１つのSheetが新規Bookのとして作成されるのです。そのコピーしたBookをSaveAsで、Sheet名の名前で保存します。

４　感想

今回のお題は、非常に実用的なものだと思いました。あるあるな状況だなと。Sheet.Copy覚えておくべき処理ですね。

ではでは、この辺で(^^)/~~~

この記事から得るもの

１ 今回のお題

２ 今回のお題の意図

３ 回答