may the VBA be with you

Excel VBAとか業務自動化とか

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回に渡ってお送りしてきたこの企画。

まだまだ書ききれていない気もしますが、一旦終わりとします。


実際に作ったマクロを使ってみて、

  • ファイルを上書きするか何もしないか、最初に一度だけ返事をして設定したい
  • コピー先ファイルのいらないシートを削除したい

とか、色々と出てくると思います。


が、



それは、また、別の話...