Excelのブックを複製するクラス

子ブックを生み出すクラス

元のブックを開いたままでコピーを作成する

元のブックのシートにデータを入力しては別名で保存して、同じ様式でデータの異なるたくさんのブックを作りたいというときがある。

Worksheetオブジェクトの場合なら、Copyメソッドがあるので簡単にできるが、WorkbookオブジェクトにはCopyメソッドがないので、上記のようなことがしたいときに、不便だなあと思っていた。

ブックの複製を作るときの考え方

  1. WorkbooksコレクションのAddメソッドで新しいブックを作る。
  2. 新しくできたブックの先頭に、元のブックのシートをケツから順に挿入していく。
  3. 新しいブックは、元のブックのシート+デフォルトのシートの状態になっているので、デフォルトのシートをケツから順に削除していく。
  4. 新ブックに新しい名前を付ける。
  5. 新ブックの各セルの参照元を新ブックに改める。
  6. 新ブックにデータを書き込むなどの処理を施す。
  7. 新ブックを保存して閉じる。

この手順でやってみた。

子ブックを生み出すクラスの作成

ソースコードを示す。

リスト1 クラスモジュール

※オブジェクト名は「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

新しくできたブックのシート名を変更している。こうしておかないと、最終的にできあがったブックのシート名が、

f:id:akashi_keirin:20170806093002j:plain

こんなふうになってしまうし、

f:id:akashi_keirin:20170806093012j:plain

数式の参照先も更新されなくなってしまう。

※なぜこうなるのかは、自分で考えてみてください。

(3)の

For i = originalWorkbook_.Worksheets.Count To 1 Step -1
  originalWorkbook_.Worksheets(i).Copy before:=newWorkbook_.Worksheets(1)
Next

では、WorksheetオブジェクトのCopyメソッドを使って新しいブックの先頭に、元のブックのシートをケツから順に挿入している。こうすることで、新しいブックは、先頭から元のブックのシートが順番通りに並び、その後ろにデフォルトのシートが並んでいる状態になる。2010以前だとデフォルトのシートが3つ、2013以降だとデフォルトのシートは1つだけですね。

で、次は(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

は、新しいブックを保存して閉じるためのメソッド。

ただし、新しいブックを生成してもいないのにコイツを実行されたら困るので、(*)からの5行、

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メソッド実行し忘れを防ぐためなのですが、これで良いのでしょうか……???

実行 その1

次のコードで実験してみる。

スト2 標準モジュール
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にしているので、単純に元のブックを名前を変えつつ3つ複製するだけのコード。

実行結果

f:id:akashi_keirin:20170806093047j:plain

「収容所」フォルダに3つのブックができている。

f:id:akashi_keirin:20170806093026j:plain

こんなふうに、参照先も新しいブックになっている。

実行 その2

今度は、次のコードで実行してみる。

リスト3 標準モジュール
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のA3セルに、自身のファイル名を書き込むようにしている。

実行結果

f:id:akashi_keirin:20170806093108j:plain

「収容所」フォルダ内に3つのブックができている。

f:id:akashi_keirin:20170806093056j:plain

Sheet3のA3セルにはファイル名が書き込まれている。

まとめ

NewWorkbookCreatorクラス 仕様
フィールド
  • newWorkbook(Workbook型。新しくできたブックを格納する。)
メソッド
  • createNewWorkbook(String newFullName,
    [Boolean enableToChangeLink],
    [Boolean enableToChangeNewWorkbook])
    元のブックを複製し、引数newFullNameをフルパスとして保存する。
    引数enableToChangeLinkがTrueならば、新しいブックの数式等の参照先は新しいブックになる。
    引数enableToChangeNewWorkbookがTrueならば、新しいブックを保存して閉じる前に一旦メソッドの呼び出し元に帰る。
  • closeNewWorkbook()
    新しいブックを保存して閉じる。

おわりに

Excelのブック(シートではなく)をデータ入力用の様式みたいに使っている場合、データを入力しては別名で保存、という繰り返しが結構発生すると思う。そんなときに、このクラスを元の様式ブックに搭載してやれば、だいぶラクになると思う。

ただ、もっと簡単なやり方がありそう。

@akashi_keirin on Twitter