【Excel】リストから複数シートを一括作成する方法 | VBA/ピボットテーブル対応

店舗一覧、支店一覧、物件一覧など、シートをまとめて追加する必要があるものの、数が多すぎて1つ1つ追加してシート名を設定するのが大変...こんな経験はないでしょうか。

この記事では、あらかじめセルに書き出したシート名のリストから、複数シートをまとめて作成する方法をご紹介します。

VBAを使う方法と、VBAに馴染みがない方向けにピボットテーブルを使う方法も記載しています。

この記事の要点

• ピボットテーブルによりシートを一括追加する方法
  • 追加したいシート名の一覧をセルにリストとして書き出す
  • 上記のリスト範囲を選択し、ピボットテーブルを作成
  • 右側の［ピボットテーブル フィールド］で、対象フィールドを［フィルター］にドラッグ
  • 画面上部の［ピボットテーブル分析］タブ→［オプション］→［レポート フィルター ページの表示］→表示されるダイアログをOK
  • シートが追加されるため、不要な見出しはホームタブ「すべてクリア」等で削除
• VBAによりシートを一括追加する方法
  • シートのA1セルから追加したいシート名のリストを記載する
  • Alt+F11を押してVBE画面を呼び出し、挿入タブ→標準モジュール
  • 記事下部のコードをコピーペーストしてF5キーで実行

以下では画像付きで詳細に説明します。VBAの抵抗がない方はVBAを使った方法を、そうでない方はピボットテーブルを使う方法が便利です。

ピボットテーブルのレポートフィルターページの表示を使う方法

追加したいシート名の一覧をリストに書き出します。

リストに書き出した範囲からピボットテーブルを作成します。
1番上の項目は見出し名となり、その名前のシートは作成されないため、その1つ下から追加したいシート名を記載してください。

右側のピボットテーブル フィールドで、フィールドを［フィルター］にドラッグします。

続いて画面上部[ピボットテーブル分析]タブから、[レポートフィルターページの表示]をクリックします。

[レポートフィルターページの表示]をクリックすると、ダイアログが開くのでOKをクリックします。

フィルターの各項目ごとに、ピボットテーブルを含むシートが自動生成されます。

1行目に不要な項目が記載されているため、グループ化（複数シート選択）してホームタブから「すべてクリア」等で削除します。その後グループ化の解除は忘れないようにご注意ください。

不要な見出しが削除され、白紙のシートが完成します。

VBAを使う方法

シートのA1セルから追加したいシート名のリストを記載します。

そのシートをアクティブにしたまま、以下のコードを実行することで、リスト通りの名称のシート一覧が追加されます。
Alt+F11
挿入タブ→標準モジュール
F5でコード実行
----------------------------------------------------------------------
Option Explicit

Public Sub CreateSheetsFromList()
    Dim wsList As Worksheet
    Dim lastRow As Long
    Dim rng As Range, c As Range
    Dim rawName As String, sheetName As String
    
    ' リストがあるシート（必要なら変更）
    Set wsList = ActiveSheet
    
    ' リスト範囲（A1から最終行まで）
    lastRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
    If lastRow < 1 Then Exit Sub
    
    Set rng = wsList.Range("A1:A" & lastRow)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each c In rng.Cells
        rawName = Trim$(CStr(c.Value))
        If Len(rawName) = 0 Then
            GoTo ContinueLoop
        End If
        
        sheetName = CleanSheetName(rawName)
        If Len(sheetName) = 0 Then
            GoTo ContinueLoop
        End If
        
        ' 既に同名シートがあればスキップ
        If Not SheetExists(sheetName) Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
        End If
        
ContinueLoop:
    Next c
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Private Function CleanSheetName(ByVal s As String) As String
    ' Excelシート名として使えない文字を置換し、31文字に切り詰める
    Dim bad As Variant, ch As Variant
    bad = Array(":", "\", "/", "?", "*", "[", "]")
    
    For Each ch In bad
        s = Replace$(s, ch, " ")
    Next ch
    
    ' 前後空白の除去＆連続スペースを詰める
    s = Application.WorksheetFunction.Trim(s)
    
    ' 先頭/末尾がアポストロフィになるのを避ける（見た目のトラブル回避）
    Do While Len(s) > 0 And Left$(s, 1) = "'"
        s = Mid$(s, 2)
    Loop
    Do While Len(s) > 0 And Right$(s, 1) = "'"
        s = Left$(s, Len(s) - 1)
    Loop
    
    If Len(s) > 31 Then s = Left$(s, 31)
    CleanSheetName = s
End Function

Private Function SheetExists(ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    SheetExists = Not ws Is Nothing
    On Error GoTo 0
End Function
----------------------------------------------------------------------

大量のシートを一括で追加したい場合にはぜひお試しください。