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

公開日：2020-11-18　最終更新日：2021-02-22

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

個人別のシートを個人別のブックに分割する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

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

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

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_28.xlsm
https://excel-ubara.com/vba100sample/VBA100_28.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

まずはDir関数+MkDirステートメントから。
100本ノックで既出なので特に解説もありません。
非表示シートのコピーはできませんので表示に切り替えています。
SaveAsはエラーになる可能性があるのでエラー処理を入れています。
部署と名前の分割にはSplit関数が便利です。


  
    
      Sub VBA100_28_01()

　　Dim wb As Workbook

　　Set wb = ActiveWorkbook

　　

　　Call setApp(False)

　　On Error Resume Next

　　

　　Dim ws As Worksheet, sPath As String

　　For Each ws In wb.Worksheets

　　　　If ws.Name Like "?*_?*" Then

　　　　　　sPath = wb.Path & "\" & Split(ws.Name, "_")(0)

　　　　　　If Dir(sPath & "\") = "" Then MkDir sPath & "\"

　　　　　　ws.Visible = xlSheetVisible

　　　　　　ws.Copy

　　　　　　With ActiveWorkbook

　　　　　　　　.SaveAs sPath & "\" & ws.Name

　　　　　　　　.Close SaveChanges:=False

      　　　　　　　　If Err Then

      　　　　　　　　　　MsgBox sPath & vbLf & vbLf & Err.Description
　　　　　　　　　　Call setApp(True)

　　　　　　　　　　Exit Sub

　　　　　　　　End If

　　　　　　End With

　　　　End If

　　Next

　　

　　Call setApp(True)

　　MsgBox "完了"

End Sub


Sub setApp(ByVal arg As Boolean)

　　With Application

　　　　.Calculation = IIf(arg, xlCalculationAutomatic, xlCalculationManual)

　　　　.DisplayAlerts = arg

　　　　.ScreenUpdating = arg

　　End With

End Sub

部署や名前を間違ってシート作成してやり直しという事もあるかもしれません。
そこで、いったんフォルダを削除する方法も考えられそうです。
FileSystemObjectを使ってフォルダ削除するVBAは記事補足に掲載しました。

補足

対象のフォルダを一旦すべて削除してから、改めて作成しています。
場合によっては、削除せずにフォルダ名を変更して履歴を残した方が良い場合もあるかもしれません。
使用場面によって考慮すべきことが変わってくると思います。


  
    
      Sub VBA100_28_02()

　　Dim wb As Workbook

　　Set wb = ActiveWorkbook

　　

　　Call setApp(False)

　　

　　Dim fso As Scripting.FileSystemObject

　　Set fso = CreateObject("Scripting.FileSystemObject")

　　

　　Dim colWs As New Collection

　　Dim ws As Worksheet

　　Dim sPath As String

　　

　　'フォルダ削除

　　For Each ws In wb.Worksheets

　　　　If ws.Name Like "?*_?*" Then

　　　　　　sPath = wb.Path & "\" & Split(ws.Name, "_")(0)

　　　　　　If Not DeleteFolder(fso, sPath) Then

　　　　　　　　MsgBox "フォルダ削除失敗。" & vbLf & sPath

　　　　　　　　Exit Sub

　　　　　　End If

　　　　　　colWs.Add ws '対象シートをCollectionに

　　　　End If

　　Next

　　

　　'シートをブック保存

　　For Each ws In colWs

　　　　sPath = wb.Path & "\" & Split(ws.Name, "_")(0)

　　　　If Not fso.FolderExists(sPath) Then

　　　　　　fso.CreateFolder sPath

　　　　End If

　　　　With CopySheet(ws)

　　　　　　.SaveAs sPath & "\" & ws.Name

　　　　　　.Close SaveChanges:=False

　　　　End With

　　Next

　　

　　Set fso = Nothing

　　Call setApp(True)

　　MsgBox "完了"

End Sub


Function DeleteFolder(ByVal fso As Scripting.FileSystemObject, ByVal sPath As String) As Boolean

　　On Error Resume Next

　　If fso.FolderExists(sPath) Then

　　　　fso.DeleteFolder sPath

　　End If

　　DeleteFolder = Not CBool(Err)

End Function


Function CopySheet(ByVal ws As Worksheet) As Workbook

　　ws.Visible = xlSheetVisible

　　ws.Copy

　　Set CopySheet = ActiveWorkbook

End Function


Sub setApp(ByVal arg As Boolean)

　　With Application

　　　　.Calculation = IIf(arg, xlCalculationAutomatic, xlCalculationManual)

　　　　.DisplayAlerts = arg

　　　　.ScreenUpdating = arg

　　End With

End Sub

いくつかFunction作成したので、全体としては長くなっていますが、
フォルダを削除している以外は、最初のVBAと変わりはありません。

サイト内関連ページ

第57回．Applicationのプロパティ（マクロ高速化と警告停止等）

・Applicationの主要プロパティ・ScreenUpdating（マクロVBAの高速化）・DisplayAlerts（警告停止）・Interactive（ユーザー操作の禁止）・Calculation（計算方法）・StatusBar ・Cursor ・その他

第59回．コレクション処理（For Each）

・For Each の構文・Exit For ・For Each の使用例・RangeオブジェクトのFor Each ・For Each サイト内の参考ページ

第66回．シートのコピー・移動・削除Copy,Move,Delete）

・シートのコピー・移動・シートの削除・シートのコピー・移動・削除の関連記事

第64回．ブックを閉じる・保存（Close,Save,SaveAs）

・ブックを閉じる・ブックを上書き保存・ブックに名前を付けて保存・ブックのコピーを保存・ブックを閉じる・保存の実践例

同じテーマ「VBA100本ノック」の記事

25本目：マトリックス表をDB形式に変換
 26本目：ファイル一覧作成
 27本目：ハイパーリンクのURL
28本目：シートをブックに分割
29本目：画像の挿入
 30本目：名札作成（段組み）
31本目：入力規則
 32本目：Excel終了とテキストファイル出力
 33本目：マクロ記録の改修
 34本目：配列の左右回転
 35本目：条件付き書式

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
5.変数宣言のDimとデータ型｜VBA入門
6.条件分岐（IF）｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.マクロとは？VBAとは？VBAでできること｜VBA入門
10.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
28本目：シートをブックに分割

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 28本目：シートをブックに分割