適材適所

PowerShellやVBAなどのプログラミングに関すること、キャリア、子育ての3本で書いていきます

Excel VBAでExcelシートを個別のブックに分割して保存する

Excel業務あるあるシリーズ。

複数のシートを独立したExcelファイルに分割して保存したい!!

ちまちまコピーして保存して・・・と手作業でやるのは効率が悪い!!

ということで今回は、シートごとに分割して保存するVBAについて紹介したいと思います。

Excel業務あるあるシリーズ

シートを分割して個別のブックに保存したい

例えば、このようなブックがあるとします。

test.xlsm

f:id:shinmai_papa:20200916215110p:plain

ブックにSheet1~Sheet4の4つのシートがあります。

やりたいのは、各シートを個別のブックに分割して

このブックと同じフォルダに保存するということです。

この状態から・・・ f:id:shinmai_papa:20200916215114p:plain こうしたい!!

f:id:shinmai_papa:20200916215117p:plain

シートを分割して保存するコード

コードは次の通りです。

Sub saveSheet()
    Dim shObj As Worksheet
    Dim newBook As Workbook
    Dim newBookName As String
    Dim folderParent As String
    
    'シートの保存先はこのブックと同じとする
    '必要に応じてこの変数を
    folderParent = ThisWorkbook.Path & "\"
    
    'ワークシートの分だけ繰り返す
    For Each shObj In Worksheets
        'シート名を変数に格納しておく
        newBookName = shObj.Name & ".xlsx"
        
        'シートを新しいブックにコピーする
        shObj.Copy
        '移動先のブックがアクティブになっているので変数に格納する
        Set newBook = ActiveWorkbook
        '新しいブックを名前を指定して保存する
        newBook.SaveAs folderParent & newBookName
        '新しいブックを閉じる
        newBook.Close
    Next shObj
End Sub

簡単な解説

この例ではブックの保存先として、下記の部分でtest.xlsmと同じフォルダを指定しています。

folderParent = ThisWorkbook.Path & "\"

ここを必要に応じて書き換えてあげることで、任意のフォルダにブックを保存することができます。

For each でブック内のすべてのシートを処理します。

'シートを新しいブックにコピーする
shObj.Copy
'移動先のブックがアクティブになっているので変数に格納する
Set newBook = ActiveWorkbook

WorksheetsオブジェクトのCopyメソッドはその名の通り、シートをコピーします。

引数はbeforeかafter、つまりどのシートの前後にシートをコピーするか指定できます。

何も指定しないと、新しいブックにコピーします。

Copyメソッドでは戻り値がないのですが、

Copy実行後はコピーして新しく作成されたブックがアクティブになる性質を利用して、

ActiveWorkBookを変数に格納してあげています。

'新しいブックを名前を指定して保存する
newBook.SaveAs folderParent & newBookName
'新しいブックを閉じる
newBook.Close

あとは、先ほどの新しく出来たブックのSaveAsメソッドを、保存先を指定して呼び出します。

これで保存ができました。

最後に保存したブックを閉じるのをお忘れなく。

直下のフォルダに保存するのではなくフォルダも新規作成したい!!

新しく作成したブックは特定のフォルダに格納したい!なんてこともあるかも知れません。

そんなときは先ほどのコードを少し改造してあげます。

保存先のフォルダも新規で作成するコード

Sub createFolderAndSaveSheet()
    Dim shObj As Worksheet
    Dim newBook As Workbook
    Dim newBookName As String
    Dim folderParent As String
    Dim folderName As String
    
    'シートの保存先はこのブックと同じとする
    '必要に応じてこの変数を
    folderParent = ThisWorkbook.Path & "\"
    
    'ワークシートの分だけ繰り返す
    For Each shObj In Worksheets
        'シート名を変数に格納する
        newBookName = shObj.Name & ".xlsx"
        'フォルダ名を変数に格納する
        folderName = folderParent & shObj.Name
        'フォルダがないことを確認する
        If Dir(folderName, vbDirectory) = "" Then
            'フォルダを新規に作成する
            MkDir folderName
        End If
        '保存しようとしているブックと同じファイル名がないか確認
        If Dir(folderName & "\" & newBookName) = "" Then
             'シートを新しいブックにコピーする
            shObj.Copy
            '移動先のブックがアクティブになっているので変数に格納する
            Set newBook = ActiveWorkbook
            '新しいブックを名前を指定して保存する
            newBook.SaveAs folderName & "\" & newBookName
            '新しいブックを閉じる
            newBook.Close
        End If
    Next shObj
End Sub

簡単な解説

'フォルダがないことを確認する
If Dir(folderName, vbDirectory) = "" Then
   'フォルダを新規に作成する
   MkDir folderName
End If
'保存しようとしているブックと同じファイル名がないか確認
If Dir(folderName & "\" & newBookName) = "" Then
  (以下略)

さきほどのコードとの違いは、Dir関数とMkdirステートメントでフォルダを操作しているところです。

Dir関数は引数に指定したパスが存在する場合、

指定したパスと一致した最初のファイル名を戻り値として返します。

第二引数は定数を指定します。vbDirectoryを指定すると一致するディレクトリ名を返してくれます。

常套手段ですが、これらの性質を逆手に取り、戻り値がブランクなら、

一致するものがない=ファイルやフォルダが存在しない

として、存在チェックを行っています。

そしてMkdirステートメントは、make directoryの略で、ディレクトリを作成します。

これでシートの数だけフォルダを作り、そこに新しく作成したブックを保存しています。

結果

上記のコードを実行すると、このようにフォルダができます。

f:id:shinmai_papa:20200916215121p:plain

各フォルダに、ちゃんとシートが格納されていることが確認できます。

f:id:shinmai_papa:20200916215125p:plain

終わりに

得意先ごとにシートを作って、フォルダに仕分けて保存して・・・

なんてことをやっている人がいたので、自動化するためのコードを紹介してみました。

他のあるあるシリーズと組み合わせれば、多くの作業が自動化できるかも・・・

ちょっとしたことですが、誰かのお役に立てば。

ここまでお読みいただきありがとうございました。