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

VBAを100本の練習問題で鍛えます
最終更新日:2021-02-22

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック


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


サンプルファイルです。
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本目:条件付き書式


新着記事NEW ・・・新着記事一覧を見る

抜けている数値を探せ|エクセル雑感(2022-07-01)
.Net FrameworkのSystem.Collectionsを利用|VBA技術解説(2022-06-29)
迷路ネコが影分身の術を体得したら…|エクセル雑感(2022-06-27)
迷路にネコが挑戦したら、どうなるかな…|エクセル雑感(2022-06-26)
サロゲートペアに対応した自作関数(Len,Left,Mid,Right)|エクセル雑感(2022-06-24)
「マクロの登録」で登録できないプロシージャーは?|エクセル雑感(2022-06-23)
オブジェクトのByRef、ByVal、Variant|エクセル雑感(2022-06-22)
コメントから特定形式の年月を取り出す|エクセル雑感(2022-06-19)
4,9を使わない連番作成|エクセル雑感(2022-06-17)
連番を折り返して出力|エクセル雑感(2022-06-16)


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

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




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


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



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