保存した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

結果の画面です。