VBA100本ノック 28本目：シートをブックに分割
ハイパーリンクのURLを取得する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
個人別のシートを個人別のブックに分けまます。
シート名は"部署_氏名"です。
ブックと同一フォルダに"部署"フォルダを作成し、シート名をブック名にして出力してください。
"部署1_日本 太郎"→"部署1"フォルダに"部署1_日本 太郎.xlsx"
※再実行を考慮
※対象ブックは任意
"部署_氏名"
この「部署」はいくつもあります。
個人別のブックを部署ごとに振り分けて出力してください。
頂いた回答
解説
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と変わりはありません。
サイト内関連ページ
同じテーマ「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コードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。