Skip to content

Instantly share code, notes, and snippets.

@KotorinChunChun
Last active August 23, 2020 14:52
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save KotorinChunChun/782555b25c0716319db52d47020aad04 to your computer and use it in GitHub Desktop.
Save KotorinChunChun/782555b25c0716319db52d47020aad04 to your computer and use it in GitHub Desktop.
戻り値のある複数シートをコピーする関数
Rem --------------------------------------------------
Rem ■戻り値のある複数シートをコピーする関数
Rem
Rem えくせるちゅんちゅん
Rem 2019/10/26
Rem https://www.excel-chunchun.com/entry/vba-sheet-copy
Rem
Rem SheetsCopy
Rem 戻り値のある複数シートをコピーする関数
Rem
Rem ToSheets
Rem あらゆる形式のデータをSheetsコレクション型に変換する関数
Rem
Rem --------------------------------------------------
Rem Copyright (c) 2019 KotoriChun
Rem URL : https://gist.github.com/kotori-chun/782555b25c0716319db52d47020aad04
Rem Twitter : @KotorinChunChun
Rem
Rem The MIT License (MIT)
Rem
Rem Permission is hereby granted, free of charge, to any person obtaining a copy
Rem of this software and associated documentation files (the "Software"), to deal
Rem in the Software without restriction, including without limitation the rights
Rem to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
Rem copies of the Software, and to permit persons to whom the Software is
Rem furnished to do so, subject to the following conditions:
Rem
Rem The above copyright notice and this permission notice shall be included in all
Rem copies or substantial portions of the Software.
Rem
Rem THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
Rem IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
Rem FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
Rem AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
Rem LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
Rem OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
Rem SOFTWARE.
Option Explicit
Rem 戻り値のある複数シートをコピーする関数
Rem
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
Dim wss As Excel.Sheets
'コピー元シートをSheets化
' SheetsやWorksheetの場合ブックは確定済のため、必ずしも省略時にアクティブブックとは限らない。
If base_book Is Nothing Then Set base_book = Excel.ActiveWorkbook
Set base_sheets = ToSheets(base_sheets, base_book)
Set base_book = base_sheets(1).Parent
'コピー先シートをSheet化
If insert_book Is Nothing Then Set insert_book = base_book
Set wss = ToSheets(insert_sheet, insert_book)
If wss Is Nothing Then
'※base_sheetsをIndex順にソートすべきかもしれない。
Set insert_sheet = IIf(isAfter, base_sheets(base_sheets.Count), base_sheets(1))
Else
Set insert_sheet = wss(1)
End If
Set insert_book = insert_sheet.Parent
'指定されたブックと、シートオブジェクトのブックが一致しないときはエラーを出すべきかもしれない。
'基本的にはシートのオブジェクトが優先されるべきなので、ブックの方は無視している。
' If insert_sheet.Parent.Name <> insert_book.Name Then Err.Raise 9999, , "指定したシートとブックが一致しない"
Dim i As Long, j As Long
'挿入前シート名リストを取得
Const Prefix = "[Copy]"
Dim wsNames As New Collection
For i = 1 To insert_book.Sheets.Count
wsNames.Add insert_book.Sheets(i).Name, "" & i
Next
For i = 1 To base_sheets.Count
wsNames.Add Prefix & i, Prefix & i
Next
'非表示シートが対象だとシートが正確な位置にコピーされないため一旦表示
Dim lastVisibled As XlSheetVisibility
lastVisibled = insert_sheet.Visible
insert_sheet.Visible = XlSheetVisibility.xlSheetVisible
Dim next_sheet As Object
Dim nextVisibled As XlSheetVisibility
Set next_sheet = insert_sheet.Next
If Not next_sheet Is Nothing Then
nextVisibled = next_sheet.Visible
next_sheet.Visible = XlSheetVisibility.xlSheetVisible
End If
'シートをコピー
If isAfter Then
base_sheets.Copy After:=insert_sheet
Else
base_sheets.Copy Before:=insert_sheet
End If
'非表示を表示にした(かもしれない)シートを元の状態に戻す
insert_sheet.Visible = lastVisibled
If Not next_sheet Is Nothing Then next_sheet.Visible = nextVisibled
'挿入後シート名リストと照合し、増加したシートを特定
If insert_book.Sheets.Count <> wsNames.Count Then Stop 'ここで止まることは無いはず。
Dim retNames
ReDim retNames(1 To base_sheets.Count)
For i = 1 To insert_book.Sheets.Count
If insert_book.Sheets(i).Name <> wsNames(i) Then
j = j + 1
retNames(j) = insert_book.Sheets(i).Name
If j = UBound(retNames) Then Exit For
End If
Next
'戻り値
Set SheetsCopy = insert_book.Sheets(retNames)
'一時表示したシートがコピー対象だと表示状態になってしまうため
'コピー後のシートにも元の表示状態を適用する(暫定版)
Dim insert_sheet_name_base As String
insert_sheet_name_base = insert_sheet.Name
If insert_sheet_name_base Like "* (#)" Or _
insert_sheet_name_base Like "* (##)" Or _
insert_sheet_name_base Like "* (###)" Or _
insert_sheet_name_base Like "* (####)" Then
insert_sheet_name_base = Left(insert_sheet_name_base, InStrRev(insert_sheet_name_base, " ") - 1)
End If
Dim ws
For Each ws In SheetsCopy
'この方法では b (2) と b (3)があったとして、それぞれの表示状態が異なっていたとき、統一されてしまう。
If ws.Name Like insert_sheet_name_base & " (*)" Then
ws.Visible = lastVisibled
End If
Next
End Function
Rem あらゆる形式のデータをSheetsコレクション型に変換する関数
Rem
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, Optional ByVal base_book As Workbook) As Sheets
Select Case TypeName(base_sheets)
Case "Sheets"
Set ToSheets = base_sheets
Case "Worksheet", "Sheet"
Set ToSheets = base_sheets.Parent.Sheets(VBA.Array(base_sheets.Name))
Case "String"
Set ToSheets = base_book.Sheets(VBA.Array(base_sheets))
Case "Integer", "Long"
Set ToSheets = base_book.Sheets(VBA.Array(base_sheets))
Case "Variant()"
Set ToSheets = base_book.Sheets(base_sheets)
Case "Nothing"
Set ToSheets = Nothing
Case Else
Debug.Print "ToSheets Not Defined Type : " & TypeName(base_sheets)
Set ToSheets = Nothing
End Select
End Function
'テスト用の環境を構築する。
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
'様々な指定方法で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
'シートをコピーするテスト
Sub Test_SheetsCopy()
Dim ws, wss As Sheets
Call DeleteSheet
'非表示シート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
'全てのシートを表示状態にする。
Sub ShowAllSheet()
Dim ws
For Each ws In ActiveWorkbook.Sheets
ws.Visible = xlSheetVisible
Next
End Sub
'[a][b][g]シートを非表示にして、コピーされたシートを削除する。
Sub DeleteSheet()
Application.DisplayAlerts = False
Dim ws
For Each ws In ActiveWorkbook.Sheets
ws.Tab.ColorIndex = xlColorIndexNone
If ws.Name Like "[abg]" Then
ws.Visible = xlSheetHidden
End If
If ws.Name Like "*(*)" Or ws.Name Like "Test*" Then
ws.Delete
End If
Next
ActiveWorkbook.Sheets(1).Select
Application.DisplayAlerts = True
End Sub
'コピーして改名したい場合
Sub Test_CopyAndRename()
SheetsCopy("Sheet1")(1).Name = "hoge"
End Sub
Sub Sample1()
Sheets(Array("a", "b")).Copy
End Sub
Sub Sample2()
Sheets("a").Copy After:=Sheets("a")
End Sub
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
Sub Sample4()
Debug.Print Sheets("a").Copy(After:=Sheets("a"))
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment