保存したExcelファイルにシートを複数追加する
保存したExcelファイルにシートを複数追加するプログラムを作成してみました。今回は「新しいExcelのファイルを作成する」のシートとプログラムを流用します。A5セルから下に追加するシート名を入力します。
one、two、three、four、fiveというのが追加するシート名になります。シート追加を行うファイルはA2セルに入力されたファイルとします。まず、シートを追加するファイルを開きます。このとき、ファイルが既に開かれている場合、二重にファイルを開いてしまう可能性があります。そのため、現在のワークブックコレクションからワークブックを一つ一つ取り出してファイルパスが同一かどうか確認をしています。もし、同一のものがあったらフラグを使って開かないようにします。次にすべてのシート名をプログラムに読み込みます。A5セルから下方向に空白になるまで配列に格納していきます。すべて格納できたら、アクティブなワークブックをシート追加対象のものに切り替えます。シートを追加して名前を変更という処理を配列の要素数分行い、ワークブックを閉じて終了です。
Public Sub AddSheets() '----------------------------- '事前準備 '----------------------------- 'A2セルのファイル名取得 Dim fPath As String fPath = getFileName 'ファイルの存在確認 If Dir(fPath, vbNormal) = "" Then MsgBox "ファイルが存在しません。" Exit Sub End If '既に開いているファイルの中に対象のファイルが存在するか確認 Dim book As Workbook Dim oFlg As Boolean oFlg = False For Each book In Workbooks 'ファイルパスが同一のものが存在する場合 If book.FullName = fPath Then oFlg = True book.Activate '後でファイル名を取得するためアクティブにしておく End If Next '存在しない場合、ファイルを開く If oFlg = False Then Workbooks.Open fPath End If 'ファイル名取得 Dim fName As String fName = ActiveWorkbook.Name '----------------------------- 'シート名の読み込み '----------------------------- ThisWorkbook.Activate '100行までループ Dim y As Integer Dim sheetName() As String Dim itemCnt As Integer itemCnt = 0 For y = 5 To 100 If Cells(y, 1).Value = "" Then Exit For '空白だったら抜ける ReDim Preserve sheetName(itemCnt) As String '前のデータを残したままで配列の再定義 sheetName(itemCnt) = Cells(y, 1).Value 'シート名を配列に格納 itemCnt = itemCnt + 1 Next '----------------------------- 'シートを追加する '----------------------------- Workbooks(fName).Activate Dim i As Integer '配列の要素分ループ '(追加シートを後側にするために、後ろからまわす) For i = UBound(sheetName) To 0 Step -1 On Error GoTo SHEET_ADD_ERR Workbooks(fName).Sheets.Add 'シート追加 ActiveSheet.Name = sheetName(i) 'シート名を変更 On Error GoTo 0 Next 'ファイルを上書き保存する Workbooks(fName).Save 'ファイルを閉じる Workbooks(fName).Close Exit Sub SHEET_ADD_ERR: MsgBox "シート追加処理でエラーが発生しました。" End Sub