Last active
August 23, 2020 14:52
-
-
Save KotorinChunChun/782555b25c0716319db52d47020aad04 to your computer and use it in GitHub Desktop.
戻り値のある複数シートをコピーする関数
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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