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

VBAを100本の練習問題で鍛えます
最終更新日:2020-11-19

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


ハイパーリンクのURLを取得する問題です。


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


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック


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


頂いた回答

解説

まずは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の記述がそれぞれ違ってきます。ブックを閉じる ブックを閉じるには、WorkbookのCloseメソッドを使用します。




同じテーマ「Python入門」の記事

VBA100本ノック 23本目:シート構成の一致確認
VBA100本ノック 24本目:全角英数のみ半角
VBA100本ノック 25本目:マトリック表をDB形式に変換
VBA100本ノック 26本目:ファイル一覧作成
VBA100本ノック 27本目:ハイパーリンクのURL
VBA100本ノック 28本目:シートをブックに分割
VBA100本ノック 29本目:画像の挿入
VBA100本ノック 30本目:名札作成(段組み)
VBA100本ノック 31本目:入力規則
VBA100本ノック 32本目:Excel終了とテキストファイル出力
VBA100本ノック 33本目:マクロ記録の改修


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

VBA100本ノック 34本目:配列の左右回転|VBA練習問題(11月28日)
VBA100本ノック 33本目:マクロ記録の改修|VBA練習問題(11月26日)
VBA100本ノック 32本目:Excel終了とテキストファイル出力|VBA練習問題(11月25日)
VBA100本ノック 31本目:入力規則|VBA練習問題(11月24日)
将棋とプログラミングについて~そこには型がある~|エクセル雑感(11月22日)
VBA100本ノック 30本目:名札作成(段組み)|VBA練習問題(11月22日)
VBA100本ノック 29本目:画像の挿入|VBA練習問題(11月21日)
VBA100本ノック 28本目:シートをブックに分割|VBA練習問題(11月19日)
VBA100本ノック 27本目:ハイパーリンクのURL|VBA練習問題(11月18日)
VBA100本ノック 26本目:ファイル一覧作成|VBA練習問題(11月17日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
5.マクロって何?VBAって何?|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




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


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



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