[作って]シートを保存するマクロ

  1. Home
  2. Excel
  3. ExcelのAI活用

【2025年9月】

前回「CSVファイルを読み込むマクロを作って」を検証したら、なんか大変なことになりました。ちなみに、詳しくは下記のページをご覧ください。

[作って]CSVを読み込むマクロ

いきなり外部ファイルの操作をお願いしたのは、無理があったかもしれません。やっぱ、Excelのマクロといえば、セルやシートの操作ですよね。なので今回は、シート操作に関する検証です。

アクティブブックのアクティブシートに、上図のようなデータがあります。シートの名前は「Sheet1」です。このシートを、独立した新しいブックとして保存します。新しく保存するブックの名前は「C:\Data\202509.xlsx」とします。

アクティブシートのデータを、新しいブックで保存するVBAのコードを作って。保存するブックの名前は「C:\Data\202509.xlsx」です。 
Sub SaveActiveSheetToNewWorkbook()
    Dim newWb As Workbook
    ActiveSheet.Copy
    Set newWb = ActiveWorkbook
    newWb.SaveAs Filename:="C:\Data\202509.xlsx", FileFormat:=xlOpenXMLWorkbook
    newWb.Close SaveChanges:=False
End Sub

おお、良いコードですね。特定のシートを新しいブックとして保存するとき「新規ブックを挿入→該当シートを新規ブックにコピー」という手順は無駄です。「ActiveSheet.Copy」だけで、アクティブシートだけが、新しいブックになります。この操作は、[ホーム]タブ-[書式]-[シートの移動またはコピー]をクリックして表示される[移動またはコピー]ダイアログボックスの「移動先ブック名」リストで「(新しいブック)」を選択したときの動作です。

私だったら、オブジェクト変数を使わないで、次のように書きますね。

Sub SaveActiveSheetToNewWorkbook()
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:="C:\Data\202509.xlsx", FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
End Sub

AIはオブジェクト変数が好きですからね。これも個性でしょうか。さて、上記のマクロでは、もし「C:\Data」フォルダに、すでに"202509.xlsx"が存在すると止まってしまいます。

(ここに上記のコードを貼り付けました) このマクロでは、すでに"C:\Data\202509.xlsx"が存在するとマクロが止まります。同じ名前のブックが存在したら「上書き保存」するには？ 
Sub SaveActiveSheetToNewWorkbook()
    Dim newWb As Workbook
    Dim filePath As String
    filePath = "C:\Data\202509.xlsx"
    
    ' 既存ファイルがあれば削除
    If Dir(filePath) <> "" Then
        Kill filePath
    End If
    
    ActiveSheet.Copy
    Set newWb = ActiveWorkbook
    newWb.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
    newWb.Close SaveChanges:=False
End Sub

なるほど「上書き保存」するのではなく、既存ファイルを削除してから保存する作戦ですね。Dir関数は、引数に指定したファイルが存在するとファイル名を返し、存在しないと空欄を返します。「<> ""」は「空欄ではない＝存在する」という意味です。続くKillステートメントは、引数に指定したファイルを削除します。ちなみに、ゴミ箱へ移動ではなく、完全削除です。

既存ファイルがあったら「キャンセルする」方も作ってもらいましょう。

(ここに最初のコードを貼り付けました)
このマクロでは、すでに"C:\Data\202509.xlsx"が存在するとマクロが止まります。同じ名前のブックが存在したら「キャンセル」するには？ 
Sub SaveActiveSheetToNewWorkbook()
    Dim filePath As String
    filePath = "C:\Data\202509.xlsx"
    
    ' ファイルが存在したらキャンセル
    If Dir(filePath) <> "" Then
        MsgBox "同じ名前のファイルが存在するため、保存をキャンセルしました。", vbExclamation
        Exit Sub
    End If
    
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
End Sub

まぁ、そうなりますね。Exit Subは、実行中のプロシージャを強制終了します。

さて、今回保存するファイル名「202509.xlsx」の"202509"部分は、現在の年月です。これを、たとえば来月になったら"202510.xlsx"と自動的にするには？

(ここに最初のコードを貼り付けました)
保存するファイル名のうち「202509」を、現在の年月にするには？ 
Sub SaveActiveSheetToNewWorkbook()
    Dim newWb As Workbook
    Dim filePath As String
    filePath = "C:\Data\" & Format(Date, "yyyymm") & ".xlsx"
    
    ActiveSheet.Copy
    Set newWb = ActiveWorkbook
    newWb.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
    newWb.Close SaveChanges:=False
End Sub

Dateは、現在の日付を返すステートメント(関数じゃありません)で、Formatは表示形式の結果を返す関数です。

フィルタの結果を保存する

ここまでは、アクティブシートをそのままブックとして保存しましたけど、アクティブシートのリストに対して、「名前」列を"田中"でフィルタし、その結果を保存するようにしたいです。実務で超あるあるですね。

アクティブシートのリストを「2列目が"田中"と等しい」でフィルタし、フィルタした結果を新しいブックとして保存するVBAのコードを作って。保存するブックの名前は「C:\Data\202509.xlsx」です。 
Sub FilterAndSaveTanaka()
    Dim ws As Worksheet
    Dim wbNew As Workbook
    Dim rng As Range
    
    Set ws = ActiveSheet
    Set rng = ws.UsedRange
    
    ' 2列目が「田中」の行でフィルタ
    rng.AutoFilter Field:=2, Criteria1:="田中"
    
    ' 新しいブックを作成し、フィルタ結果をコピー
    Set wbNew = Workbooks.Add
    rng.SpecialCells(xlCellTypeVisible).Copy Destination:=wbNew.Sheets(1).Range("A1")
    
    ' フィルタ解除
    ws.AutoFilterMode = False
    
    ' 新しいブックを保存
    wbNew.SaveAs Filename:="C:\Data\202509.xlsx", FileFormat:=xlOpenXMLWorkbook
    wbNew.Close SaveChanges:=False
End Sub

SpecialCells(xlCellTypeVisible) は、いわゆる"可視セル選択"です。本当はこれ、不要なんですけどね。まぁ、無駄が多いのも、ある意味でAIの個性でしょう。ちなみに、私が書くなら、次のようにします。

Sub FilterAndSaveTanaka2()
    Dim rng As Range
    
    Set rng = ActiveSheet.UsedRange
    rng.AutoFilter 2, "田中"
    Workbooks.Add
    rng.Copy Range("A1")
    rng.Parent.AutoFilterMode = False
    
    ActiveWorkbook.SaveAs "C:\Data\202509.xlsx"
    ActiveWorkbook.Close
End Sub

複数のリストを結合して保存する

最後に、複数のリストを縦に結合して、その結果を保存するマクロを作ってもらいます。ここまでの流れでいくと、かなり期待できそうですね。

[9月]シートと[10月]シートに、それぞれリストがあります。どちらのリストもヘッダは「日付・名前・記号・地域・数値」ですが、データの件数(行数)は未定です。新しいワークシートを挿入し、そこに[9月]シートのリストと[10月]シートのリストを結合して、結合した結果を新しいブックとして保存するVBAのコードを作って。保存するブックの名前は「C:\Data\202509.xlsx」です。

さて、伝わるかな？

Sub MergeAndSaveLists()
    Dim ws9 As Worksheet, ws10 As Worksheet, wsNew As Worksheet
    Dim lastRow9 As Long, lastRow10 As Long, lastCol As Long
    Dim wbNew As Workbook
    
　  Set ws9 = ThisWorkbook.Sheets("9月")
    Set ws10 = ThisWorkbook.Sheets("10月")
    
    ' 新しいワークシートを追加
    Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "結合リスト"
    
    ' 9月シートのデータをコピー
    lastRow9 = ws9.Cells(ws9.Rows.Count, 1).End(xlUp).Row
    lastCol = ws9.Cells(1, ws9.Columns.Count).End(xlToLeft).Column
    ws9.Range(ws9.Cells(1, 1), ws9.Cells(lastRow9, lastCol)).Copy wsNew.Cells(1, 1)
    
    ' 10月シートのデータをコピー（ヘッダを除く）
    lastRow10 = ws10.Cells(ws10.Rows.Count, 1).End(xlUp).Row
    ws10.Range(ws10.Cells(2, 1), ws10.Cells(lastRow10, lastCol)).Copy wsNew.Cells(lastRow9 + 1, 1)
    
    ' 新しいブックを作成して貼り付け
    Set wbNew = Workbooks.Add
    wsNew.UsedRange.Copy wbNew.Sheets(1).Cells(1, 1)
    wbNew.SaveAs Filename:="C:\Data\202509.xlsx", FileFormat:=xlOpenXMLWorkbook
    wbNew.Close SaveChanges:=False
    
    MsgBox "結合して保存しました。"
End Sub

上から順番に解説します。まず「ThisWorkbook」とは、このマクロが書かれているブックを表します。もし、同時に複数のブックが開いていると、どのブックがアクティブブックになるか分かりませんので、誤動作を避けるために、よく使います。なので、安全のためには必要なのですが、いかんせん、スペルが長いです。その結果、次の「新しいシートを挿入する」部分が、とても冗長に見えます。この長さになると、ビギナーは読むのにも苦労するでしょう。なので、私だったら、この「ThisWorkbook」をWithで括ります。AIが提示するコードでは、あまりWithを見かけませんが、可読性を高めるためにも、積極的に利用したいです。Withを使うと、次のように短くなります。

【Before】
Set ws9 = ThisWorkbook.Sheets("9月")
Set ws10 = ThisWorkbook.Sheets("10月")

' 新しいワークシートを追加
Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsNew.Name = "結合リスト"

【After】
With ThisWorkbook
    Set ws9 = .Sheets("9月")
    Set ws10 = .Sheets("10月")
    
' 新しいワークシートを追加
    Set wsNew = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wsNew.Name = "結合リスト"
End With

このマクロのポイントは、9月のデータはヘッダごとコピーするけど、10月のデータはヘッダを除いた実データ部分(2行目から下)をコピーするところです。提示されたコードでは、Range(左上, 右下)の"左上"を、9月→セルA1、10月→セルA2と指定することで対処しています。見事です。

最後の「新しいブックを作成して貼り付け」は、ちょっと残念ですね。最初に提示されたコードでは、同じ処理を「ActiveSheet.Copy」とシンプルに実行しています。その方法を知っているのなら、今回も使って欲しかったです。このへんが、AI特有の"ゆらぎ"や"ぶれ"なのでしょうね。同じ結果でも、異なる書き方はたくさんあります。プログラムを作る人は、その人なりの主義や主張を持ち、一貫性のある統一されたコードを書きます。その方が、メンテナンスやデバッグしやすいからです。AIに部分的なコードを書いてもらうと、そのときによって一貫性のないコードが提示されます。それを、そのままコピーして寄せ集めると、結局「何をやっているのか分からない」「担当者がいないと直せない」などの属人化を招くでしょうね。気をつけたいものです。

おまけ

さて、最後の「9月と10月を結合して保存する」ですが、かなり反則ですけど、私だったら次のようにしますね。

Sub Sample1()
    Sheets.Add.Name = "結合リスト"
    Range("A1").Formula2 = "=VSTACK('9月'!A:.E,DROP('9月'!A:.E,1))"
    Range("A:A").NumberFormat = "yyyy/m/d"
    Range("A1#").Value = Range("A1#").Value
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs "C:\Data\202509.xlsx"
    ActiveWorkbook.Close
End Sub

2つのリストを結合するなんて、今のExcelだったら、ワークシート関数の方が簡単です。結合する数式を一度セルに入れて、その結果を値貼り付けしています。まぁ、AIは絶対に提示しないでしょうけどｗ もちろん、VSTACK関数、DROP関数、TRIMRANGE関数が使えるExcelでしか動作しません。