Office TANAKA - Excel VBA Tips[シートを別ブックとして保存する]

実務では、特定のシートだけを別ブックとして保存することが多いです。たとえば、Sheet1とSheet2があったとして。このSheet2の名前を"田中"に変え、"田中"シートだけを「田中.xlsx」として保存する。みたいな。

このとき、ほとんどの方が次のように考えます。

まずSheet2の名前を"田中"に変える
新しいブックを挿入する
[田中]シートを、挿入した新しいブックにコピーする
新しいブックで、"田中"以外のシートを削除する
挿入したブックを"田中.xlsx"で保存する

この考え方でマクロを作ってみましょう。こうなります。

Sub Sample1()
    Dim ws As Worksheet
    Sheets("Sheet2").Name = "田中"    ''1.
    Workbooks.Add                     ''2.
    ThisWorkbook.Sheets("田中").Copy After:=ActiveWorkbook.Sheets(Sheets.Count)    ''3.
    Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> "田中" Then ws.Delete        ''4.
    Next ws
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs "D:\Work\田中.xlsx"      ''5.
    ActiveWorkbook.Close
End Sub

ちなみに、3.のとき、コピーではなく移動したいのでしたら、CopyではなくMoveを使います。

シートを別のブックにコピーする
ThisWorkbook.Sheets("田中").Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
は、2つのブックを開いておいて、シート見出しをCtrlキーを押しながらドラッグする操作をマクロ記録すると分かります。

面倒くさいのは4.の手順です。新規ブックには、必ず(少なくとも1枚の)ワークシートが存在しますから、それらを削除します。コピーした[田中]シート以外を削除する便利な方法はありませんから、1枚ずつワークシートの名前を調べて、"田中"ではなかったら削除です。このとき「ほんとに削除していいの？ねぇ？いいの？」とウザイ確認が出てマクロが止まってしまいますから、DisplayAlerts に False を代入して抑止しています。

実務では"あるある"の作業なだけに、こうしたコードをよく見かけます。でも、待ってください。特定のシートだけを新しいブックにするのって、Excelの標準機能にあるんですよ。

コピーしたいシートのシート見出しを右クリックして、表示されるメニューの[移動またはコピー]を実行します。

表示されるダイアログボックスの、[移動先ブック名]リストで「(新しいブック)」を選択します。もしコピーしたいのでしたら、[コピーを作成する]チェックボックスをオンにします。移動したいのでしたら、このチェックボックスはオフのままです。

[OK]ボタンをクリックすれば、選択したシートだけが新しいブックになります。ほかのSheet1とか余計なシートはありません。

このように、任意のシートだけを別ブックとしてコピーするのでしたら、この機能を使えば楽勝です。ちなみに次のように書きます。

Sub Sample2()
    Sheets("田中").Copy
End Sub

たったこれだけです。実際にやってみてください。上記のようなマクロを書いていたのでしたら、きっと笑っちゃいますw この方法を使えば

新しいブックを挿入する
[田中]シートを挿入した新しいブックにコピーする

が1行で済みます。さらに、面倒くさい

新しいブックで、"田中"以外のシートを削除する

が不要になります。したがって、[田中]シートだけを「田中.xlsx」として保存するのは、次のコードで十分です。

Sub Sample2()
    Sheets("Sheet2").Name = "田中"
    Sheets("田中").Copy
    ActiveWorkbook.SaveAs "D:\Work\田中.xlsx"
    ActiveWorkbook.Close
End Sub

実務でよくあるケースをやってみましょう。Sheet1(アクティブシート)に次のようなリストがあります。

Sheet2の名前を、これら9人の名前に変えて、それぞれ「有村.xlsx」「松本.xlsx」など個別のブックを作ります。よくこういうとき、それぞれのシートに固有の名前とか代入しますので、それもやってみます。

Sub Sample3()
    Dim i As Long, Target As String
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Target = Cells(i, 1)
        Sheets(2).Name = Target
        Sheets(Target).Range("A1") = Target
        Sheets(Target).Copy
        ActiveWorkbook.SaveAs "D:\Work\" & Target & ".xlsx"
        ActiveWorkbook.Close
    Next i
End Sub

Sheets(Target)のところを、次のように書くとエラーになりますので注意してください。

Sub Sample3()
    Dim i As Long
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(2).Name = Cells(i, 1)
        Sheets(Cells(i, 1)).Range("A1") = Target
        Sheets(Cells(i, 1)).Copy
        ActiveWorkbook.SaveAs "D:\Work\" & Target & ".xlsx"
        ActiveWorkbook.Close
    Next i
End Sub

どうしても変数を使いたくないのでしたら、次のようにValueプロパティをつけます。

Sub Sample3()
    Dim i As Long
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(2).Name = Cells(i, 1)
        Sheets(Cells(i, 1).Value).Range("A1") = Target
        Sheets(Cells(i, 1).Value).Copy
        ActiveWorkbook.SaveAs "D:\Work\" & Target & ".xlsx"
        ActiveWorkbook.Close
    Next i
End Sub

この件、詳しくは

セルの文字列でシートを特定するときの注意

をご覧ください。

複数シートをコピー/移動するとき

まぁ、上に書いた方法で1枚ずつ操作すればいいんですけど、希に複数のシートを一気にコピー/移動したいこともあるでしょう。あるかな？一応書いておきます。

複数のシートを一気に別ブックとしてコピーするには、次のようにします。

Sub Sample4()
    Sheets(Array("Sheet2", "Sheet3")).Copy
End Sub

これはマクロ記録で記録されるコードです。実務でのポイントは、このように複数のシートをコピーするとき

コピーする複数のシートを、あらかじめ手動操作で選択しておき、それらをコピーする
マクロで毎回、コピーする複数のシートを特定する

の、どちらかということです。

1.だったら簡単です。ああ、もちろん、マクロ記録で記録される方法ではできません。シート名は毎回変わるはずですから。そんなときは、次のようにします。

Sub Sample5()
    ActiveWindow.SelectedSheets.Copy
End Sub

SelectedSheetsプロパティは、現在選択されているシートを返します。ただ、このSelectedSheetsプロパティは、Workbookオブジェクトではなく、Windowオブジェクトのプロパティです。

詳しくは

現在選択されているシートを操作する

をご覧ください。

さて、問題は2.です。これは、いろんな状況が考えられます。

コピーする複数のシートを、あらかじめ手動操作で選択しておき、それらをコピーする
マクロで毎回、コピーする複数のシートを特定する
1. シートの枚数は決まっているけど、名前が毎回違う
2. 特定のシート以外の、すべてのシートをコピーしたい

2-aは、たとえば次のようなケースです。

もちろん名前は「松本_予算」「松本_実績」のように変わります。これだったら、先のコードを応用して作れます。

Sub Sample6()
    Dim i As Long, Target As String
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Target = Cells(i, 1)
        Sheets(2).Name = Target & "_予算"
        Sheets(3).Name = Target & "_実績"
        Sheets(Array(Target & "_予算", Target & "_実績")).Copy
        ActiveWorkbook.SaveAs "D:\Work\" & Target & ".xlsx"
        ActiveWorkbook.Close
    Next i
End Sub

問題は、2-bです。Array関数は、引数の数(配列の要素数)が決まっているときはいいのですが、要素数が可変になると使い勝手が悪いです。こんなときは、動的配列を使って、自分で(シート名の)配列を作ります。ここでは、次のようなケースで「Sheet1以外のすべて」を別ブックにコピーします。もちろん、Sheet1以外のシートが何枚あるかは分からないという前提です。ただし、Sheet1は常に左端に存在するものとします。なお、ブックを保存するところなどは同じですから、ここでは「Sheet1以外のすべて」のシート名を配列に格納するところだけ書きます。

Sub Sample7()
    Dim A() As String, i As Long
    ReDim A(Sheets.Count - 2)
    For i = 2 To Sheets.Count
        A(i - 2) = Sheets(i).Name
    Next i
    Sheets(A).Copy
End Sub

こんな感じですかね。配列がよく分からないというのでしたら、いっそのこと、対象のシートを毎回選択状態にして、その選択されたシートをコピーするという手もあります。参考までに書いておきます。

Sub Sample8()
    Dim i As Long
    Sheets(2).Select
    For i = 3 To Sheets.Count
        Sheets(i).Select False
    Next i
    ActiveWindow.SelectedSheets.Copy
End Sub

Select False に関しては、

シートをグループ化する

をご覧ください。