Excel VBA 逆引き集 | ピボットの自動作成

Excel VBA
スポンサーリンク

ピボットの自動作成

「明細からピボットを毎回作るのが面倒」を一撃で解決するテンプレをまとめました。最短コード、テーブルを元データにした安全版、見出し名で柔軟に項目を設定、複数ピボットの一括生成まで、初心者でも壊れにくい形で解説します。

基本テンプレート：CurrentRegionからピボットを作成

Sub CreatePivot_FromCurrentRegion()
    '元データはアクティブシートのA1起点の表（見出し含む）
    Dim src As Range
    Set src = Range("A1").CurrentRegion

    '出力先シートと場所（A3セル）を用意
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("ピボット")
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add
        outWs.Name = "ピボット"
    End If
    On Error GoTo 0

    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=src)
    Set pt = pc.CreatePivotTable(TableDestination:=outWs.Range("A3"), TableName:="明細ピボット")

    'フィールド配置（例：行=部署、列=レベル、値=金額合計）
    With pt
        .PivotFields("部署").Orientation = xlRowField
        .PivotFields("レベル").Orientation = xlColumnField
        With .PivotFields("金額")
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
        End With
    End With
End Sub
VB
  • ポイント:
    • CurrentRegionは見出し付きの「連続した表」を一発取得できて楽。
    • 先に出力先シートを確保してから作成。初回でも安心。

安全運用版：元データをテーブル化してから作成

Sub CreatePivot_FromTable()
    '元データシートとテーブル名
    Dim dataWs As Worksheet: Set dataWs = Worksheets("データ")
    Dim lo As ListObject

    'A1の表をテーブル化（既にテーブルがある場合は取得）
    On Error Resume Next
    Set lo = dataWs.ListObjects(1)
    On Error GoTo 0
    If lo Is Nothing Then
        Set lo = dataWs.ListObjects.Add(xlSrcRange, dataWs.Range("A1").CurrentRegion, , xlYes)
        lo.Name = "明細テーブル"
    End If

    '出力先
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("ピボット")
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add
        outWs.Name = "ピボット"
    End If
    On Error GoTo 0

    'テーブルをソースにピボット作成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo.Name)
    Set pt = pc.CreatePivotTable(TableDestination:=outWs.Range("A3"), TableName:="明細ピボット")

    '例の配置：行=日付(月表示)、列=部署、値=金額合計
    With pt
        .PivotFields("日付").Orientation = xlRowField
        .PivotFields("日付").NumberFormat = "yyyy-mm"
        .PivotFields("部署").Orientation = xlColumnField
        With .PivotFields("金額")
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
        End With
    End With
End Sub
VB
  • ポイント:
    • テーブル化すると行が増減してもソース範囲が自動で追従。更新ミスが減る。
    • ピボット側のソース指定はテーブル名だけで簡潔。

見出し名で柔軟にフィールドを設定（列順が変わっても壊れない）

Sub CreatePivot_ByHeaderNames()
    Dim src As Range: Set src = Worksheets("データ").Range("A1").CurrentRegion

    '出力先
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("ピボット")
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add
        outWs.Name = "ピボット"
    End If
    On Error GoTo 0

    'ピボット作成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=src)
    Set pt = pc.CreatePivotTable(TableDestination:=outWs.Range("A3"), TableName:="柔軟ピボット")

    '見出し名を使って安全にフィールド追加
    AddRowField pt, "部署"
    AddColumnField pt, "商品"
    AddDataFieldSum pt, "金額", "#,##0"

    '必要に応じて数値ではなく件数に切り替え
    'AddDataFieldCount pt, "商品", "件数"
End Sub

Private Sub AddRowField(ByVal pt As PivotTable, ByVal headerName As String)
    With pt
        If FieldExists(pt, headerName) Then .PivotFields(headerName).Orientation = xlRowField
    End If
End Sub

Private Sub AddColumnField(ByVal pt As PivotTable, ByVal headerName As String)
    With pt
        If FieldExists(pt, headerName) Then .PivotFields(headerName).Orientation = xlColumnField
    End If
End Sub

Private Sub AddDataFieldSum(ByVal pt As PivotTable, ByVal headerName As String, ByVal numFmt As String)
    With pt
        If FieldExists(pt, headerName) Then
            With .PivotFields(headerName)
                .Orientation = xlDataField
                .Function = xlSum
                .NumberFormat = numFmt
            End With
        End If
    End With
End Sub

Private Sub AddDataFieldCount(ByVal pt As PivotTable, ByVal headerName As String, ByVal caption As String)
    With pt
        If FieldExists(pt, headerName) Then
            With .PivotFields(headerName)
                .Orientation = xlDataField
                .Function = xlCount
                .Caption = caption
            End With
        End If
    End With
End Sub

Private Function FieldExists(ByVal pt As PivotTable, ByVal headerName As String) As Boolean
    Dim f As PivotField
    On Error Resume Next
    Set f = pt.PivotFields(headerName)
    FieldExists = Not f Is Nothing
    On Error GoTo 0
End Function
VB
  • ポイント:
    • 見出しが変わっても安全に追加。存在チェックでエラー回避。
    • 合計と件数を切り替えるヘルパー関数で読みやすく。

複数ピボットを一括生成（部署別や月次別を量産）

Sub CreateMultiplePivots()
    Dim src As Range: Set src = Worksheets("データ").Range("A1").CurrentRegion

    'パターン定義（行/列/値）
    CreateOnePivot src, "部署×レベル", "部署", "レベル", "金額", xlSum
    CreateOnePivot src, "月次×部署", "日付", "部署", "金額", xlSum, "yyyy-mm"
    CreateOnePivot src, "商品件数", "商品", vbNullString, "商品", xlCount
End Sub

Private Sub CreateOnePivot(ByVal src As Range, ByVal sheetName As String, _
                           ByVal rowField As String, ByVal colField As String, _
                           ByVal dataField As String, ByVal func As XlConsolidationFunction, _
                           Optional ByVal rowFormat As String = vbNullString)
    '出力先
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets(sheetName)
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add
        outWs.Name = sheetName
    End If
    outWs.Cells.Clear
    On Error GoTo 0

    '作成
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=src)
    Set pt = pc.CreatePivotTable(TableDestination:=outWs.Range("A3"), TableName:=sheetName & "_PT")

    '行フィールド
    If rowField <> vbNullString And FieldExists(pt, rowField) Then
        pt.PivotFields(rowField).Orientation = xlRowField
        If Len(rowFormat) > 0 Then pt.PivotFields(rowField).NumberFormat = rowFormat
    End If

    '列フィールド
    If colField <> vbNullString And FieldExists(pt, colField) Then
        pt.PivotFields(colField).Orientation = xlColumnField
    End If

    '値フィールド
    If FieldExists(pt, dataField) Then
        With pt.PivotFields(dataField)
            .Orientation = xlDataField
            .Function = func
            If func = xlSum Then .NumberFormat = "#,##0"
        End With
    End If
End Sub
VB
  • ポイント:
    • 複数パターンを一気に量産。行の表示形式（yyyy-mmなど）も指定可能。
    • シートが無ければ自動作成、既存ならクリアして上書き。

高速・安全ラップ（大量明細のとき）

Sub SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 作成前後で挟むだけで体感速度が改善。エラー時も必ず復帰させる。

よくある落とし穴と対策

  • 見出し名が違ってフィールド追加で失敗する
    • 対策: 存在チェック（FieldExists）を必ず挟む。見出しの表記ゆれは事前に統一。
  • 元データ範囲が増えても反映されない
    • 対策: テーブル化（ListObject）してソースにテーブル名を使う。
  • 同名のピボットやシートが衝突する
    • 対策: 一意な名前を付ける、既存シートは Cells.Clear で中身だけ消す。
  • 日付の月/年表示がうまくいかない
    • 対策: PivotFields("日付").NumberFormat = "yyyy-mm"（年は”yyyy”）。必要ならグループ機能も活用。
  • 作成後に更新忘れ
    • 対策: 作成直後に pt.PivotCache.Refresh を呼ぶ、もしくは開いたときに全更新イベントを用意。

例題で練習

'例1：CurrentRegionから「部署×レベル×金額合計」のピボットを作る
Sub Example_BasicCreate()
    Call CreatePivot_FromCurrentRegion
End Sub

'例2：テーブルをソースにして「日付(月)×部署×金額合計」で作る
Sub Example_TableSource()
    Call CreatePivot_FromTable
End Sub

'例3：見出し名指定で柔軟作成（列順変更に強い）
Sub Example_ByHeaders()
    Call CreatePivot_ByHeaderNames
End Sub

'例4：3種類のピボットを一括で量産
Sub Example_Multi()
    Call CreateMultiplePivots
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました