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

最終更新日：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は、Excel全体をあらわすオブジェクトです。つまり、エクセルそのものだと考えて下さい。ここでは、そのプロパティの一部を紹介します。ここで紹介するApplicationのプロパティはほんの一部です。

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

ForEachは、コレクションの各要素に対して繰り返し処理を実行します。コレクションはオブジェクトの集まりですので、ForEachは、コレクションの中から、個々のオブジェクトを取り出して処理する場合に使用します。コレクションの全ての要素に対しての処理が終わるとループは終了します。

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

シートのコピーや移動をしたり、また削除する場合の説明です。マクロVBAでは、雛形シートをコピーして使ったり、不要なシートを削除することは頻繁にあります。シートのコピー・移動には、Worksheet.Copyメソッド、Worksheet.Moveメソッドこれら、WorkSheetオブジェクトのメソッドを使用します。

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

ワークブックを閉じる場合や保存する場合のマクロVBAの説明です。閉じる時に保存するか保存しないかを指定できます。また、ブックを保存するにも、上書きなのか別ファイルにするのか等によってVBAの記述がそれぞれ違ってきます。

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

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

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.Excelショートカットキー一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.RangeとCellsの使い方｜VBA入門
5.繰り返し処理（For Next)｜VBA入門
6.マクロって何？VBAって何？｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
9.セルに文字を入れるとは（Range,Value）｜VBA入門
10.並べ替え（Sort）｜VBA入門

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

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

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

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