えくせるちゅんちゅん

ことりがエクセルをちゅんちゅんするブログ

トップ > Excel > VBAで戻り値のある複数シートをコピーする関数を作ってみた

VBAで戻り値のある複数シートをコピーする関数を作ってみた

Excel VBA VBA汎用関数

今回はVBAで戻り値のある複数シートをコピーする関数を作ってみたので紹介します。

f:id:Kotori-ChunChun:20191026215236p:plain

きっかけ

本記事は、下記の記事を読んでもっと上手い方法があるのではないかと思ったので作り始めたはいいが、想定以上に考慮すべき事が多くて大変だったという話である。

akashi-keirin.hatenablog.com

f:id:Kotori-ChunChun:20210602212541p:plain

今回は複数シートのコピーを行いたいので、単数形のWorksheetではなく、複数形のWorksheetsかSheetsを使用する。


Worksheets.Copy / Sheets.Copyメソッド の互換関数自作の要件

f:id:Kotori-ChunChun:20210602212917p:plain

Sheets.Copy メソッドは、Microsoftによると随分と単純に記載されている。

docs.microsoft.com

しかし実際にはそんなに甘くない。


要件1. 複数のシートを纏めてコピーできるようにする

いきなり余談だが、Sheets オブジェクト (Excel) によれば、名称は「Sheets オブジェクト」なのだが本文では「Sheets コレクション」と書かれている。

実際のところObject型のシートが大量に入ったコレクションなので、ここでは分かりやすいようコレクションと呼ぶことにする。

指定されたブックまたは作業中のブックにあるすべてのシートのコレクションです。

Sheets コレクションには、 Chart オブジェクトまたは Worksheet オブジェクトを含めることができます。

使用例は以下の通り。

Sub Sample1()
    Sheets(Array("a", "b")).Copy
End Sub

従って、Sheets.Copyメソッドを再現するには、複数のシートを纏めてコピーできるように作らなければならない。

今回の関数作成では「一括処理」を優先すべきか、「100%の安全性」を優先すべきかで迷った結果、「一括処理」の方を優先した。

その理由は、シートを同時にコピーした場合と1枚づつコピーした場合では、シート間を参照する数式の保持のされ方に差があるからである。


要件2. コピー先の位置はオブジェクト以外でも指定する

Sheets.CopyメソッドはBeforeとAfterという二種類の省略可能引数を持っており、どちらかしか指定してはならない。両方を指定すると実行時エラーが発生する。

公式では下記のように記載されている。

シートをブック内の他の場所にコピーします。

逆に両方を省略しても良い。後々に書いてあるように、

Before と After の両方を省略すると、コピーしたシートを含む新しいブックが作成されます。

また、別のブックのシートオブジェクトを指定すれば、別のブックの任意のシートのとなりにコピーすることもできる。

それは良いとして。

使ったことがある人なら分かると思うが、このオブジェクトを指定するという仕様がすごくメンドクサイ。

例えば、あるシートをコピーしてすぐ右に作成したい場合、こんなふうに二度もSheets("a")と書かなければならない。

Sub Sample2()
    Sheets("a").Copy After:=Sheets("a")
End Sub

普通に考えて、隣にコピーするという運用が一番多くて、別のブックにコピーするなどという事は少ないような気がする。

コピー元シートからの前後をTrue/Falseで指定出来たら便利ではないだろうか。

Sub Sample2()
    Sheets("a").Copy isAfter:=True
End Sub


要件3. 非表示のシートがあっても正しい位置にコピーする

通常、下記のようなシート構成のときに

f:id:Kotori-ChunChun:20191026201557p:plain

Sheets("a").Copy After:=Sheets("a")を実行

f:id:Kotori-ChunChun:20191026201604p:plain

しかし、隣のシートが非表示だと正しい位置にはコピーされない。

例えば実際のシートがこの内容で

f:id:Kotori-ChunChun:20191026201126p:plain

表示状態が下記の状態で

f:id:Kotori-ChunChun:20191026201135p:plain

Sheets("a").Copy After:=Sheets("a")を実行

f:id:Kotori-ChunChun:20191026201143p:plain

実際には非表示シートよりも後の位置にコピーされる

f:id:Kotori-ChunChun:20191026201149p:plain


じゃあどうすりゃ良いのかと言うと、次のシートを表示してからコピーすれば良い。

Sub Sample3_1()
    Sheets("a").Next.Visible = xlSheetVisible
    Sheets("a").Copy After:=Sheets("a")
End Sub

しかし、この方法では隠されていたシートが表示されたままになってしまう。


だから現状を記憶してから表示して、コピーが終わったらもとに戻すという処理が必要になる。

Sub Sample3_2()
    Dim nextVisible As XlSheetVisibility
    Dim nextSheet: Set nextSheet = Sheets("a").Next
    nextVisible = nextSheet.Visible
    nextSheet.Visible = xlSheetVisible
    
    Sheets("a").Copy After:=Sheets("a")
    
    nextSheet.Visible = nextVisible
End Sub


さらに、非表示のシートを隣にコピーしたい場合、コピー後のシートが表示状態になってしまうので、それも元の状態に戻すという処理が必要になるかもしれない。


しかし・・・コピーされたシートを安全に特定する方法が無いのである


要件4. コピーされたシートオブジェクト群を返せるようにする

遅くなったが、Copyメソッドを拡張したくなるのはこれが最大の理由だと思う。

Addメソッド等には戻り値で追加されたオブジェクトを返す仕組みがあるのに、Copyメソッドには何故か用意されていない。

なぜか？それは分からない。

ただ、動かしてみて初めて知った。

ドキュメントには書かれていないがTrueが返るらしい。

Sub Sample4()
     Debug.Print Sheets("a").Copy(After:=Sheets("a"))
End Sub

このTrueが一体何を示しているのかは不明だが、きっと成功したって意味なんだろうなと想像する。

（でも失敗時はエラー出るから、Falseを返す場面が無いような？）


要件5. コピーされたシート群に名前がつけられるようにする

Sheets.Copyメソッドには、コピー後の名前を付けるような機能がない。

従って一旦シートをコピーして、コピーされたシートを特定して.Nameプロパティを変更しない限り、名前を付けることはできない。


シートがコピーされた時、Excelが一定の法則でシート名を付けてくれることに着目する人もいるかもしれない。

たしかに、自動的に元の名前 (番号)を付与したシート名を作成してくれる。

しかしこの自動採番のルールが非常に複雑で、

  • aをコピーするとa (2)を作成する
  • ただしa (2)が存在する場合はa (3)を作成する
  • a (2)をコピーした場合もa (3)を作成する
  • ただしa (5)が存在するからと言って、a (4)を飛ばしてa (6)が作成されるようなことはない。（常に最小の空き番号が付与される）
  • ただしa (4)が無い状態でa (5)をコピーしたときはa (6)が作成される。（コピー元の番号より大きい番号を付与する）

と、なっているらしい。

※Office 365 2019/10/26 時点


コピーされたシートを名称から特定するのが、如何に難しいかがお分かり頂けたことだろう。


コピーされたシートを特定する方法

コピーされたシートを特定する方法は4種類浮かんだ。

  • Copy実行後のActivateSheetから特定する方法
  • Before,Afterからの相対位置(Next,Previous)から特定する方法
  • 自動生成された名前から特定する方法
  • Copyメソッド実行前後のSheetsコレクションの差分から特定する方法


Copy実行後のActiveSheetから特定する方法

たぶん、これが一番一般的でしょう。

Sub Example1_1()
    Sheets("a").Visible = xlSheetVisible
    Sheets("a").Copy After:=Sheets("a")
    Debug.Print ActiveSheet.Name
    'a (2)  ※OK
End Sub


でも、複数シートの場合は、先頭シートだけしか選択状態にならないので、コピーされたシート一式を取得したいという要件に適していません。

Sub Example1_2()
'    Sheets(Array("a", "b")).Visible = xlSheetVisible
    Sheets("a").Visible = xlSheetVisible
    Sheets("b").Visible = xlSheetVisible
    Sheets(Array("a", "b")).Copy After:=Sheets("a")
    Debug.Print ActiveSheet.Name
    'a (2) ※b (2)は検出できない
End Sub


さらに非表示シートにも対応していません。

全く関係のない右隣の可視シートが選択状態になります。

さらに、末尾のシートでは最後尾の可視シートが選択状態になります。

Sub Example1_3()
    Sheets("a").Visible = xlSheetHidden
    Sheets("a").Copy After:=Sheets("a")
    Debug.Print ActiveSheet.Name
    'b     ※無関係なシートを検出する
End Sub

一旦シートを全部表示してからコピーして特定できるようにするしかありません。


Before,Afterからの相対位置(Next,Previous)から特定する方法

Before, Afterを指定している場合に限って、指定したシートからの相対位置で指定することができます。

ActiveSheetを禁止している人でも安心して使う事ができるのがメリットです。

Beforeを指定したならPrevious、Afterを指定したならNextを使います。

Sub Example3_1()
    Sheets("a").Copy After:=Sheets("a")
    Debug.Print Sheets("a").Previous.Name
End Sub

しかし、ActiveSheetと同じで、複数シートの検知に対応できません。


自動生成された名前から特定する方法

前述の通り、自動採番が複雑なのでとても難解なコードになります。

Sub Example2_1()
    Sheets("a").Visible = xlSheetVisible
    Sheets("a").Copy After:=Sheets("a")
    Debug.Print Sheets("a (2)").Name
End Sub

大変なプログラムを書かなければならないので、今回はこれで勘弁して下さい。


Copyメソッド実行前後のSheetsコレクションの差分から特定する方法

  • コピーされたオブジェクトは分からない。
  • コピーされた名前も分からない。
  • コピーされるインデックスも不安定で分からない。

じゃあ、差分を取れば良いじゃない！と、今回、私が記事を書こうと思った方法である。

理論上はどんな想定外の動きをされようと、差分を取れば確実に抽出できるはず。


Sub Example4_1()
    Dim base_sheets
    Set base_sheets = Sheets(Array("a", "b"))

    Dim i As Long, j As Long
    
    '挿入前シート名リストを取得
    Dim wsNames As New Collection
    For i = 1 To Sheets.Count
        wsNames.Add Sheets(i).Name, "" & i
    Next
    For i = 1 To base_sheets.Count
        wsNames.Add "[Copy]" & i, "[Copy]" & i
    Next
    
    base_sheets.Copy After:=Sheets("a")
    
    '挿入後シートリストと照合
    Dim retNames
    ReDim retNames(1 To base_sheets.Count)
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> wsNames(i) Then
            j = j + 1
            retNames(j) = Sheets(i).Name
            Debug.Print j, Sheets(i).Name
            If j = base_sheets.Count Then Exit For
        End If
    Next
    
    Dim copyed_sheets
    Set copyed_sheets = Sheets(retNames)
    copyed_sheets.Select
    '1      a (2)
    '2      b (2)
End Sub

一応上手く行ったが、コピー元とコピー後の紐付けが出来ていないため、完全性は担保できなかった。

もう少し改良が必要かもしれない。


完成したプログラム


関数の仕様

今回は最終的に2の関数が出来上がった。

  • ToSheets関数 あらゆる形式のデータをSheetsコレクション型に変換する関数
  • SheetsCopy関数 戻り値のある複数シートをコピーする関数


サンプルは下記のマクロを実行して

'テスト用の環境を構築する。
Sub TestStart()
    Workbooks.Add
    Dim sh2 As Object
    Set sh2 = Worksheets.Add(After:=Sheets(1))
    Worksheets.Add(Before:=sh2).Name = "a"
    Charts.Add(Before:=sh2).Name = "g"
    Worksheets.Add(Before:=sh2).Name = "b"
End Sub

このような状態でテストするものとする。

f:id:Kotori-ChunChun:20191026212408p:plain


ToSheets関数

あらゆる形式のデータをSheetsコレクション型に変換する関数である。

Rem  @name ToSheets
Rem
Rem  @param base_sheets     任意の型のシートを示すデータ(index,name,worksheet,sheet,sheets)
Rem  @param base_book       シートにブック情報がなかった場合の既定のブック
Rem
Rem  @return As Sheets      シートコレクション
Rem
Function ToSheets(ByVal base_sheets, ByVal base_book As Workbook) As Sheets

こんな感じの使い方ができる

Sub Test_ToSheets()

    Dim wss As Excel.Sheets
    
    Debug.Print ToSheets(1, ActiveWorkbook)(1).Name
    
    Debug.Print ToSheets("a", ActiveWorkbook)(1).Name
    
    Debug.Print ToSheets(Sheets("a"))(1).Name
    
    Debug.Print ToSheets(Worksheets("b"))(1).Name
    
    Set wss = ToSheets(VBA.Array(1, 2), ActiveWorkbook)
    Debug.Print wss(1).Name, wss(2).Name
    
    Set wss = ToSheets(VBA.Array("a", "b"), ActiveWorkbook)
    Debug.Print wss(1).Name, wss(2).Name
    
    Set wss = ToSheets(Sheets(VBA.Array("a", "b")))
    Debug.Print wss(1).Name, wss(2).Name
    
End Sub

実行結果

Sheet1
a
a
b
Sheet1     a
a       b
a       b

便利でしょ？


SheetsCopy関数

戻り値のある複数シートをコピーする関数である。

Rem  @param base_sheets     コピー元シート(index,name,object)
Rem  @param isAfter         False:=前へ追加、True:=後へ追加(既定)
Rem  @param insert_sheet    挿入前後シート(index,name,object)、省略時はコピー元シート
Rem  @param base_book       コピー元ブック（base_sheetsがindexやnameの時のみ有効。省略時:ActiveWorkbook）
Rem  @param insert_book     挿入先ブック(insert_sheetがindexやnameの時のみ有効。省略時:base_book)
Rem
Rem  @return As Sheets      コピーされたシートリスト
Rem
Rem  @note                  現在の方法で問題が起こる事は極めて少ないが完全とは言えない。
Rem                           代替案1.コピー前にセルや名前定義に元のシート名を記載しておく。
Rem                           代替案2.コピーを1シートづつ行う。
Rem                         グラフシートをコピーした場合シートが表示状態になるバグあり？
Rem                         シートが存在しない場合のエラー処理を書いていない。
Rem
Function SheetsCopy(ByVal base_sheets, _
                    Optional ByVal isAfter As Boolean = True, _
                    Optional ByVal insert_sheet = Nothing, _
                    Optional ByVal base_book As Excel.Workbook = Nothing, _
                    Optional ByVal insert_book As Excel.Workbook = Nothing) As Excel.Sheets

見ての通り原形を留めていない（笑）が、私としてはすごく使いやすくなっていると思う。

'シートをコピーするテスト
Sub Test_SheetsCopy()

    Dim ws, wss As Sheets
    
    '非表示シートaを(aの後に)コピーして名前を付ける
    SheetsCopy(Worksheets("a"))(1).Name = "Test1"
    
    '非表示シートbをTest1の後にコピーして名前を付ける
    SheetsCopy(Worksheets("b"), True, Worksheets("Test1"))(1).Name = "Test2"
    
    'Sheet1とSheet2をSheet2の手前にコピーして名前を付ける
    Dim i As Long: i = 0
    For Each ws In SheetsCopy(Array("Sheet1", "Sheet2"), False, "Sheet2")
        i = i + 1
        ws.Name = "Test3-" & i
    Next
    
    '非表示シートa b g をコピーして a (2) b (2) g (2) を作成し、
    '色を付けて、可視状態にして、選択状態にする
    Set wss = SheetsCopy(Sheets(Array("a", "b", "g")))
    For Each ws In wss
        Debug.Print ws.Name
        ws.Tab.Color = vbRed
        ws.Visible = XlSheetVisibility.xlSheetVisible
    Next
    wss.Select
    
End Sub

実行すると下図のような結果になる。

f:id:Kotori-ChunChun:20191026212631p:plain

尚、Test1,Test2は非表示シートのままなので表示されていない。


戻り値がSheetsコレクションを基本としているので、単一シート専用で扱いたい人には(1)と毎回書くのが不便かもしれないが、必要なら単一シート用にラップすればいいと思う。


ソースコード


課題

Sheets.Copyメソッドは、コピー元のコレクションの順番は考慮せず、コピー元シートのインデックスを基準に整列してシートが作成される模様

Sub Test_Copy1()
    Dim base_sheets
    Set base_sheets = Sheets(Array("Sheet1", "Sheet2"))
    Debug.Print base_sheets(1).Name, base_sheets(2).Name
    'Sheet1     Sheet2
    
    base_sheets.Copy
    Debug.Print Sheets(1).Name, Sheets(2).Name
    'Sheet1     Sheet2
End Sub

Sub Test_Copy2()
    Dim base_sheets
    Set base_sheets = Sheets(Array("Sheet2", "Sheet1"))
    Debug.Print base_sheets(1).Name, base_sheets(2).Name
    'Sheet2     Sheet1
    
    base_sheets.Copy
    Debug.Print Sheets(1).Name, Sheets(2).Name
    'Sheet1     Sheet2  ←　元のシートの並び順に整列されている！！！
End Sub


関連ツイート

Twitter

https://twitter.com/KotorinChunChun/status/1187988719791329282?s=20


まとめ

シートのコピーはExcelが良い感じに勝手にやってくれる処理が多くて、想定以上に苦労した。

今回の関数は結構使えると思うので、愛用のライブラリに登録して使っていきたい。

以上

何か御座いましたらコメント欄、またはTwitterからどうぞ♪

それではまた来週♪　ちゅんちゅん(・8・)