VBAなんだかんだ その4 新しく作ったブックにシートをコピーして保存して閉じるのをシートの数だけ繰り返す
はじめに
前回、
vba-belle-equipe.hatenablog.com
これができるようになったので、あとは繰り返すだけです。
書いてみる
いきなりですが、前回の処理をfor~eachに入れてみましょう。
Sub copyAllSheets() Dim ws As Worksheet For Each ws In Worksheets Workbooks.Add Workbooks("コピー元.xlsx").Worksheets(1).Copy _ Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs Filename:="C:\test\test.xlsx" ActiveWorkbook.Close Next End Sub
今回は本番のつもりなので、調子に乗ってそれっぽい名前をつけてみます。
あと、横に長いのは改行しときましょう(半角スペース + アンダーバー)。
やってみる
さあ実行、といいたいところですが、怒られるのが目に見えています。
Sub copyAllSheets() Dim ws As Worksheet For Each ws In Worksheets Workbooks.Add Workbooks("コピー元.xlsx").Worksheets("[シート変えないとダメ]").Copy _ Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs Filename:="[ファイル変えないとダメ]" ActiveWorkbook.Close Next End Sub
- コピー元のワークシートは「ws」でオッケーでしょう。
- 出力ファイル名は、せっかくだからコピー元のシート名にしましょう
ということで
Sub copyAllSheets() Dim ws As Worksheet For Each ws In Worksheets Workbooks.Add ws.Copy Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs _ Filename:="[保存先パス]" & ws.name & ".xlsx" ActiveWorkbook.Close Next End Sub
こんなもんでどうでしょうか。
ローカル ディスク(C:) └test └コピー元1.xlsx └コピー元2.xlsx └コピー元3.xlsx
できましたねえ。
・・・・・・・・・・・・・・・・・
おまけ
なんとなく、物足りないのでおまけ。
自ブックからのコピーに限定
このままだと、マクロ実行時にアクティブなブックのシートがコピーされます。
それはそれでいいのですが、マクロが書いてあるブックからのコピーにしたい場合
Sub copyAllSheets() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets Workbooks.Add ws.Copy Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs _ Filename:="[保存先パス]" & ws.name & ".xlsx" ActiveWorkbook.Close Next End Sub
「ThisWorkbook」をつけます。
ファイル上書きメッセージを表示させない
同じマクロを連続で実行すると「上書きしますか」的なメッセージが出ます。
いちいち返事していられないので、出さないようにしましょう。
問答無用で上書き
「vba 上書き確認 表示させない」で検索してみましょう。
Sub copyAllSheets() Dim ws As Worksheet Application.DisplayAlerts = False For Each ws In ThisWorkbook.Worksheets Workbooks.Add ws.Copy Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs _ Filename:="[保存先パス]" & ws.name & ".xlsx" ActiveWorkbook.Close Next Application.DisplayAlerts = True End Sub
「Application.DisplayAlerts」というのをいじります。
存在する場合は何もしない
「vba ファイルが存在するか」で検索すると、「Dir」で確認できることがわかります。
Sub copyAllSheets() Dim ws As Worksheet Dim filePath As String Application.DisplayAlerts = False For Each ws In ThisWorkbook.Worksheets filePath = "[保存先パス]" & ws.name & ".xlsx" If Dir(filePath) = "" Then Workbooks.Add ws.Copy Before:=ActiveWorkbook.Worksheets(1) ActiveWorkbook.SaveAs fileName:=filePath ActiveWorkbook.Close End If Next Application.DisplayAlerts = True End Sub
存在しない場合だけ処理をするようにしてみました。
まとめ
vba-belle-equipe.hatenablog.com
上の記事で書ききれなかった部分を4回に渡ってお送りしてきたこの企画。
まだまだ書ききれていない気もしますが、一旦終わりとします。
実際に作ったマクロを使ってみて、
- ファイルを上書きするか何もしないか、最初に一度だけ返事をして設定したい
- コピー先ファイルのいらないシートを削除したい
とか、色々と出てくると思います。
が、
それは、また、別の話...