VBA100本ノック 28本目：シートをブックに分割
個人別のシートを個人別のブックに分割する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。
出題
出題ツイートへのリンク
#VBA100本ノック 28本目
個人別のシートを個人別のブックに分けまます。
シート名は"部署_氏名"です。
ブックと同一フォルダに"部署"フォルダを作成し、シート名をブック名にして出力してください。
"部署1_日本 太郎"→"部署1"フォルダに"部署1_日本 太郎.xlsx"
※再実行を考慮
※対象ブックは任意
少しわかりづらい部分がありそうなので補足します。
"部署_氏名"
この「部署」はいくつもあります。
個人別のブックを部署ごとに振り分けて出力してください。
サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_28.xlsm
https://excel-ubara.com/vba100sample/VBA100_28.zip
個人別のシートを個人別のブックに分けまます。
シート名は"部署_氏名"です。
ブックと同一フォルダに"部署"フォルダを作成し、シート名をブック名にして出力してください。
"部署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関数が便利です。
部署や名前を間違ってシート作成してやり直しという事もあるかもしれません。
そこで、いったんフォルダを削除する方法も考えられそうです。
FileSystemObjectを使ってフォルダ削除するVBAは記事補足に掲載しました。
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は記事補足に掲載しました。
補足
対象のフォルダを一旦すべて削除してから、改めて作成しています。
場合によっては、削除せずにフォルダ名を変更して履歴を残した方が良い場合もあるかもしれません。
使用場面によって考慮すべきことが変わってくると思います。
いくつかFunction作成したので、全体としては長くなっていますが、
フォルダを削除している以外は、最初の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本ノック」の記事
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
26本目：ファイル一覧作成・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
27本目：ハイパーリンクのURL・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
28本目：シートをブックに分割29本目：画像の挿入
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
30本目：名札作成（段組み）・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
31本目：入力規則・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
32本目：Excel終了とテキストファイル出力・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
33本目：マクロ記録の改修・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
34本目：配列の左右回転・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
35本目：条件付き書式・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 28本目：シートをブックに分割
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。