2020年12月11日

Excel 特定のシートを複数のブックへコピーする

'特定のシートを複数のブックへコピーする
'【使い方】
'任意のシートで、"A1"から下方向に自身のブック内にあるコピー元対象のシート名を列挙する。
'"B1"から下方向にコピー先対象のブック(ファイル名)を列挙する。ファイルを自身のファイルと同じ場所に置く。
'ActiveXボタンを配置し当プロシージャを貼り付ける
Private Sub CommandButton1_Click()

'定数
Const SHEET_MAX As Integer = 10
Const BOOK_MAX As Integer = 10

'確認メッセージ
Dim res
res = MsgBox("処理を開始します。" & vbNewLine & "よろしいですか?", vbYesNo + vbDefaultButton2 + vbQuestion, "確認")
If res = vbNo Then Exit Sub

Dim curSheet As Worksheet
Set curSheet = ThisWorkbook.ActiveSheet

Dim path As String
path = ThisWorkbook.path

'コピー元シート取得
Dim sheetsBase As String
sheetsBase = "A1"
Dim sourceSheetList As Range
Set sourceSheetList = curSheet.Range(sheetsBase, curSheet.Range(sheetsBase).Offset(SHEET_MAX, 0))
'Set sourceSheetList = curSheet.Range(sheetsBase, curSheet.Range(sheetsBase).End(xlDown))

'コピー先ブック取得
Dim bookBase As String
bookBase = "B1"
Dim targetBookList As Range
Set targetBookList = curSheet.Range(bookBase, curSheet.Range(bookBase).Offset(BOOK_MAX, 0))
'Set targetBookList = curSheet.Range(bookBase, curSheet.Range(bookBase).End(xlDown))


Dim targetBook As Workbook
Dim sourceSheet As Worksheet

' 各ブックを開く
For Each bookName In targetBookList
On Error Resume Next
Set targetBook = Nothing
Set targetBook = Workbooks.Open(path & "\" & bookName.Value)
On Error GoTo 0
If Not targetBook Is Nothing Then
' 各シートをコピー
For Each sheetName In sourceSheetList
'シートを特定
On Error Resume Next
Set sourceSheet = Nothing
Set sourceSheet = ThisWorkbook.Worksheets(sheetName.Value)
On Error GoTo 0
If Not sourceSheet Is Nothing Then
'ワークブックへシートをコピー
sourceSheet.Copy After:=targetBook.Sheets(targetBook.Sheets.Count)
End If
Next
'保存する
targetBook.Save
'閉じる
targetBook.Close
End If
Next

res = MsgBox("終了しました。", vbOK + vbInformation, "メッセージ")

End Sub
タグ:Excel VBA
posted by Hiro at 19:38| Comment(10) | プログラム