Excelのブックを複製するクラス
子ブックを生み出すクラス
元のブックを開いたままでコピーを作成する
元のブックのシートにデータを入力しては別名で保存して、同じ様式でデータの異なるたくさんのブックを作りたいというときがある。
Worksheetオブジェクトの場合なら、Copyメソッドがあるので簡単にできるが、WorkbookオブジェクトにはCopyメソッドがないので、上記のようなことがしたいときに、不便だなあと思っていた。
ブックの複製を作るときの考え方
- WorkbooksコレクションのAddメソッドで新しいブックを作る。
- 新しくできたブックの先頭に、元のブックのシートをケツから順に挿入していく。
- 新しいブックは、元のブックのシート＋デフォルトのシートの状態になっているので、デフォルトのシートをケツから順に削除していく。
- 新ブックに新しい名前を付ける。
- 新ブックの各セルの参照元を新ブックに改める。
- 新ブックにデータを書き込むなどの処理を施す。
- 新ブックを保存して閉じる。
この手順でやってみた。
子ブックを生み出すクラスの作成
ソースコードを示す。
リスト１ クラスモジュール
※オブジェクト名は「NewWorkbookCreator」
Option Explicit
'Fields'
Private originalWorkbook_ As Workbook
Private newWorkbook_ As Workbook
Private originalFileFullName_ As String
Private newFileFullName_ As String
'Accessor'
Public Property Get newWorkbook() As Workbook
Set newWorkbook = newWorkbook_
End Property
'Constructor'
Private Sub Class_Initialize()
Set originalWorkbook_ = ThisWorkbook
originalFileFullName_ = originalWorkbook_.FullName
End Sub
'Destructor'
Private Sub Class_Terminate()
If Not newWorkbook_ Is Nothing Then Call closeNewWorkbook
End Sub
'Methods'
Public Sub createNewWorkbook(ByVal newFullName As String, _
Optional ByVal enableToChangeLink As Boolean = True, _
Optional ByVal enableToChangeNewWorkbook = True)
'コピー元ブックと同じフルパスを指定していたらエラーを吐かせる。 ……(1)'
If newFullName = originalFileFullName_ Then
Err.Raise Number:=10001, _
Description:="コピー元ブックと同じフルパスでは実行できません。"
Exit Sub
End If
'新ブックを追加。'
Set newWorkbook_ = Workbooks.Add
Dim i As Integer
'コピー先ブックのシート名をデフォルト名から変えておく ……(2)'
With newWorkbook_
For i = 1 To .Worksheets.Count
If .Worksheets(i).Name = "Sheet" & i Then
.Worksheets(i).Name = .Worksheets(i).Name & "_"
End If
Next
End With
'画面更新を止める'
Application.ScreenUpdating = False
'コピー元ブックのシートをケツから順に新ブックの先頭に挿入。 ……(3)'
For i = originalWorkbook_.Worksheets.Count To 1 Step -1
originalWorkbook_.Worksheets(i).Copy before:=newWorkbook_.Worksheets(1)
Next
'新ブックにもともとあったシートを削除 ……(4)'
For i = newWorkbook_.Worksheets.Count To originalWorkbook_.Worksheets.Count + 1 Step -1
'シート削除時のアラートを表示させない。'
Application.DisplayAlerts = False
newWorkbook_.Worksheets(i).Delete
Next
newWorkbook_.SaveAs Filename:=newFullName
'ブック内の参照元ブックを新ブックに改める。 ……(5)'
If enableToChangeLink = True Then
newWorkbook_.ChangeLink name:=originalWorkbook_.FullName, _
NewName:=newWorkbook_.FullName, _
Type:=xlLinkTypeExcelLinks
End If
If enableToChangeNewWorkbook = False Then Call closeNewWorkbook '……(6)'
End Sub
Public Sub closeNewWorkbook() '……(7)'
If newWorkbook_ Is Nothing Then '……(*)'
Err.Raise Number:=10001, _
Description:="新ブック生成前に実行できません。"
Exit Sub
End If
'新ブックを保存して閉じる。'
newWorkbook_.Close True
'アラート表示と画面更新を元に戻す。'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'オブジェクト変数を空にする。'
Set newWorkbook_ = Nothing
End Sub
(1)の
If newFullName = originalFileFullName_ Then
Err.Raise Number:=10001, _
Description:="コピー元ブックと同じフルパスでは実行できません。"
Exit Sub
End If
はコメントの通り。エラーを吐いてプログラマに知らせるべきことだと思うので、こうした。
(2)では、
With newWorkbook_
For i = 1 To .Worksheets.Count
If .Worksheets(i).Name = "Sheet" & i Then
.Worksheets(i).Name = .Worksheets(i).Name & "_"
End If
Next
End With
新しくできたブックのシート名を変更している。こうしておかないと、最終的にできあがったブックのシート名が、
こんなふうになってしまうし、
数式の参照先も更新されなくなってしまう。
※なぜこうなるのかは、自分で考えてみてください。
(3)の
For i = originalWorkbook_.Worksheets.Count To 1 Step -1 originalWorkbook_.Worksheets(i).Copy before:=newWorkbook_.Worksheets(1) Next
では、WorksheetオブジェクトのCopyメソッドを使って新しいブックの先頭に、元のブックのシートをケツから順に挿入している。こうすることで、新しいブックは、先頭から元のブックのシートが順番通りに並び、その後ろにデフォルトのシートが並んでいる状態になる。2010以前だとデフォルトのシートが３つ、2013以降だとデフォルトのシートは１つだけですね。
で、次は(4)の
For i = newWorkbook_.Worksheets.Count To originalWorkbook_.Worksheets.Count + 1 Step -1 'シート削除時のアラートを表示させない。' Application.DisplayAlerts = False newWorkbook_.Worksheets(i).Delete Next
で新しいブックのケツにくっついている余分なシート（デフォルトのシート）をケツから削除していく。
なぜ「ケツから」なのかは、よく考えてください。
(5)の
If enableToChangeLink = True Then
newWorkbook_.ChangeLink Name:=originalWorkbook_.FullName, _
NewName:=newWorkbook_.FullName, _
Type:=xlLinkTypeExcelLinks
End If
では、新しいブックの数式等の参照先を自分自身に改めている。これをやっておかないと、数式等の参照先が全部元のブックになってしまう。
参照先を元のブックのままにしておきたいときは、このcreateNewWorkbookメソッド実行時に、引数enableToChangeLinkをFalseにすればいいのだが、そのような需要はまずなかろうと思うので、メソッドの定義時に
Optional ByVal enableToChangeLink As Boolean = True
こんなふうに、この引数を省略可能にしてデフォルトをTrueにしておいた。
(6)の
If enableToChangeNewWorkbook = False Then Call closeNewWorkbook
では、引数enableToChangeNewWorkbookの値により、一旦呼び出し元に処理を返すか、このまま新しいブックを保存して閉じるかを分岐している。
単純に全く同じブックを名前だけ変えて複製するのなら、引数enableToChangeNewWorkbookをFalseにして実行すればよい、ということ。まあ、あんまりそんなことはしないと思うけど。
(7)の
Public Sub closeNewWorkbook()
If newWorkbook_ Is Nothing Then '……(*)'
Err.Raise Number:=10001, _
Description:="新ブック生成前に実行できません。"
Exit Sub
End If
'新ブックを保存して閉じる。'
newWorkbook_.Close True
'アラート表示と画面更新を元に戻す。'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'オブジェクト変数を空にする。'
Set newWorkbook_ = Nothing
End Sub
は、新しいブックを保存して閉じるためのメソッド。
ただし、新しいブックを生成してもいないのにコイツを実行されたら困るので、(*)からの５行、
If newWorkbook_ Is Nothing Then
Err.Raise Number:=10001, _
Description:="新ブック生成前に実行できません。"
Exit Sub
End If
で、newWorkbook_がNothingのとき、すなわちまだ新しいブックが追加されていない場合はエラーを吐くようにした。これまたユーザに知らせるべきことではないと思うので。
あと、今回は珍しくデストラクタを作った。
Private Sub Class_Terminate() If Not newWorkbook Is Nothing Then Call closeNewWorkbook End Sub
新しいブックを作って、処理を施した後のcloseNewWorkbookメソッド実行し忘れを防ぐためなのですが、これで良いのでしょうか……？？？
実行 その１
次のコードで実験してみる。
リスト２ 標準モジュール
Public Sub testNewWorkbookCreator_01() Dim str As String str = ThisWorkbook.Path & "\収容所\" '" 'このブックのあるディレクトリに「収容所」フォルダがなかったら作る。' If Dir(str, vbDirectory) = "" Then MkDir str End If '変数宣言＆インスタンス化' Dim nwbCreator As NewWorkbookCreator Set nwbCreator = New NewWorkbookCreator Dim i As Integer Dim tmp As String For i = 1 To 3 tmp = "_" & Format(i, "0#") nwbCreator.createNewWorkbook newFullName:=str & "新ブック" & tmp, _ enableToChangeLink:=True, _ enableToChangeNewWorkbook:=False '……(*)' Next End Sub
(*)のところで、createNewWorkbookメソッドの引数enableToChangeNewWorkbookをFalseにしているので、単純に元のブックを名前を変えつつ３つ複製するだけのコード。
実行結果
「収容所」フォルダに３つのブックができている。
こんなふうに、参照先も新しいブックになっている。
実行 その２
今度は、次のコードで実行してみる。
リスト３ 標準モジュール
Public Sub testNewWorkbookCreator_02() Dim str As String str = ThisWorkbook.Path & "\収容所\" '" 'このブックのあるディレクトリに「収容所」フォルダがなかったら作る。' If Dir(str, vbDirectory) = "" Then MkDir str End If '変数宣言＆インスタンス化' Dim nwbCreator As NewWorkbookCreator Set nwbCreator = New NewWorkbookCreator Dim i As Integer Dim tmp As String For i = 1 To 3 tmp = "_" & Format(i, "0#") With nwbCreator .createNewWorkbook newFullName:=str & "新ブック加工" & tmp, _ enableToChangeLink:=True, _ enableToChangeNewWorkbook:=True '……(*)' .newWorkbook.Worksheets("Sheet3").Range("A3").Value = .newWorkbook.Name '……(**)' .closeNewWorkbook End With Next End Sub
今度は、(*)のところで、引数enableToChangeNewWorkbookをTrueにした。こうすることで、createNewWorkbookメソッドはcloseNewWorkbookメソッドを呼び出すことなく終了するので、処理が呼び出し元のtestNewWorkbookCreator_02に帰ってきて、(**)を実行することになる。
(**)の
nwbCreator.newWorkbook.Worksheets("Sheet3").Range("A3").Value = .newWorkbook.Name
では、新しいブックのSheet3のＡ３セルに、自身のファイル名を書き込むようにしている。
実行結果
「収容所」フォルダ内に３つのブックができている。
Sheet3のＡ３セルにはファイル名が書き込まれている。
まとめ
NewWorkbookCreatorクラス 仕様
フィールド
- newWorkbook（Workbook型。新しくできたブックを格納する。）
メソッド
- createNewWorkbook(String newFullName,
[Boolean enableToChangeLink],
[Boolean enableToChangeNewWorkbook])
元のブックを複製し、引数newFullNameをフルパスとして保存する。
引数enableToChangeLinkがTrueならば、新しいブックの数式等の参照先は新しいブックになる。
引数enableToChangeNewWorkbookがTrueならば、新しいブックを保存して閉じる前に一旦メソッドの呼び出し元に帰る。 - closeNewWorkbook()
新しいブックを保存して閉じる。
おわりに
Excelのブック（シートではなく）をデータ入力用の様式みたいに使っている場合、データを入力しては別名で保存、という繰り返しが結構発生すると思う。そんなときに、このクラスを元の様式ブックに搭載してやれば、だいぶラクになると思う。
ただ、もっと簡単なやり方がありそう。
