ピボットテーブル作成用クラスモジュール

ピボットテーブル作成用に、クラスモジュールを作成してみた。

私的利用向けであるため、汎用性はさほど高くない。とりあえず備忘録として、こちらにまとめておく。

◆ソースコード（クリックで展開）◆

Option Explicit

Public Pvt As Excel.PivotTable

Dim PvtField As Excel.PivotField
Dim PvtItem As Excel.PivotItem

Enum FormatType
    ft標準
    ft数値
    ft通貨
    ft会計
    ft短い日付形式
    ft長い日付形式
    ft時刻
    ftパーセンテージ
    ft分数
    ft指数
    ft文字列
    ft桁区切り
    [_ft_eLast]
End Enum

' ピボットテーブル作成。
Public Function MakePivotTable(source As Variant, _
                      Optional sheet_name As String = vbNullString, _
                      Optional table_destination As String = "R3C1", _
                      Optional table_name As String = vbNullString) _
                      As Boolean
    
    ' 以下の場合、新規にシートを作成する。
    ' ① 指定された名前のシートが存在しない場合。
    ' ② シートの指定が無い場合。
    Dim Sh As Worksheet
    Dim Ws As Worksheet
        If sheet_name = vbNullString Then
            Set Sh = Sheets.Add
                ' シート名が無指定の場合、重複しないよう日付で命名。
                Sh.Name = "SheetForPivot_" & Format(Now, "yyyymmdd_hhmmss")
        Else
            ' 指定された名前のシートを探し、
            ' 見つかればShにセットする。
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Set Sh = Ws
                    Exit For
                End If
            Next
            ' 見つからなければ、新規に作成する。
            If Sh Is Nothing Then
                Set Sh = Sheets.Add
                    Sh.Name = sheet_name
                    Sh.Move After:=Sheets(Sheets.Count)
            End If
        End If
        
        ' ピボットテーブル名が無指定の場合、重複しないように日付で命名。
        If table_name = vbNullString Then
            table_name = "PivotTable_" & Format(Now, "yyyymmdd_hhmmss")
        End If
        
    Dim SourceTable As ListObject
        ' sourceのType確認。
        Select Case TypeName(source)
            ' テーブルの場合。
            Case "ListObject"
                Set SourceTable = source
            ' シート上の範囲が指定された場合。
            Case "Range"
                Set SourceTable = MakeTable(source.CurrentRegion)
        End Select
        
        If IsArray(source) Then
            Dim TableSheet As Worksheet
            Set TableSheet = Sheets.Add
                TableSheet.Range("A1").Resize(UBound(source, 1), UBound(source, 2)) = source
                TableSheet.Name = "SheetForTable_" & Format(Now, "yyyymmdd_hhmmss")
            Set SourceTable = MakeTable(TableSheet.UsedRange)
            Sh.Select
        End If
    
    On Error GoTo er:
    Set Pvt = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
                                                SourceData:=SourceTable, _
                                                Version:=PvtVersion).CreatePivotTable _
                    (TableDestination:=Sh.Name & "!" & table_destination, _
                     TableName:=table_name, _
                     DefaultVersion:=PvtVersion)
        
        ' ピボットテーブル作成成功。
        MakePivotTable = True
        Exit Function
er:
        ' ピボットテーブル作成失敗。
        MakePivotTable = False
        On Error GoTo 0
End Function

Public Function MakeTable(source_range As Range, _
                 Optional table_name As String = vbNullString) As ListObject
    Set MakeTable = source_range.ListObject
    If MakeTable Is Nothing Then
        Set MakeTable = source_range.Parent.ListObjects.Add(xlSrcRange, source_range, , xlYes)
        With MakeTable
            If table_name = vbNullString Then
                .Name = "Table_" & Format(Now, "yyyymmdd_hhmmss")
            End If
            .TableStyle = SetPersonalTableStyle
            With .Range.Cells
                .Font.Name = "メイリオ"
                .Font.Size = 10
                .RowHeight = 20
                .EntireColumn.AutoFit
            End With
        End With
    End If
End Function

' 各フィールドの設定。
Public Sub SetFields(field_orientation As XlPivotFieldOrientation, _
                     ParamArray field_names())
    
    ' ピボットテーブルの作成済み確認。
    If Pvt Is Nothing Then Exit Sub
    
    ' フィールドをセット。
    ' field_orientationの内訳は下記のとおり。
    ' ① xlPageField　：フィルター
    ' ② xlRowField 　：行
    ' ③ xlColumnField：列
    ' ④ xlDataField　：値
    
    ' フィルターはセットした順に位置が下になるので、指定した
    ' フィールド名の最後から逆順でセットする。
    Dim i As Long
    
    Select Case field_orientation
        
        Case xlPageField
            For i = UBound(field_names) To 0 Step -1
                Pvt.PivotFields(field_names(i)).Orientation = field_orientation
            Next
        
        Case Else
            For i = 0 To UBound(field_names)
                Pvt.PivotFields(field_names(i)).Orientation = field_orientation
            Next
    
    End Select
End Sub

' レポートのレイアウト変更。
Public Sub SetRowAxisLayout(Optional layout_row_type As XlLayoutRowType = xlTabularRow)
    ' ピボットテーブルの作成済み確認。
    If Pvt Is Nothing Then Exit Sub
    
    Pvt.RowAxisLayout layout_row_type
End Sub

' 小計の表示設定。
Public Sub SetSubTotals(Optional subtotal_visible As Boolean = False, _
                        Optional subtotal_location As XlSubtototalLocationType = xlAtBottom)
                        
    Select Case subtotal_visible
    
        ' 小計を表示する場合。
        Case True
            Pvt.SubtotalLocation subtotal_location
        
        ' 小計を表示しない場合。
        Case False
            On Error Resume Next
            For Each PvtField In Pvt.PivotFields
                PvtField.Subtotals(1) = True
                PvtField.Subtotals(1) = False
            Next
            
    End Select
End Sub

' 値フィールドの設定。
Public Sub SetValueField(Optional consolidation_function _
                            As XlConsolidationFunction = xlSum, _
                         Optional data_field_index _
                            As Long = 0)

    ' 指定した「data_field_index」番目が存在しない場合、処理を中断する。
    If data_field_index > Pvt.DataFields.Count Then Exit Sub

    ' 指定した「data_field_index」が「０番目」である場合、すべての
    ' データフィールドの集計方法を統一する。
    Dim arr As Variant
        Select Case data_field_index
            Case 0
                Dim DataField As PivotField
                    For Each DataField In Pvt.DataFields
                        
                        ' データフィールドの名称が、「平均 / 合計 / 年齢」のように
                        ' 意図しない表示になる場合がある。対策として、キャプションを
                        ' 一旦「 / 」で分割し、その最後の配列要素に集計名を付している。
                        ' 集計名は「AggregationMethodNameDict」を作成して取得している。
                        DataField.Function = consolidation_function
                        arr = Split(DataField.Caption, " / ")
                        DataField.Caption = AggregateMethodNameDict(consolidation_function) & _
                                            " / " & arr(UBound(arr))
                    Next
            Case Else
                With Pvt.DataFields(data_field_index)
                    .Function = consolidation_function
                    arr = Split(.Caption, " / ")
                    .Caption = AggregateMethodNameDict(consolidation_function) & _
                               " / " & arr(UBound(arr))
                End With
        End Select

End Sub

' 値フィールドの設定に使用する集計名辞書。
Private Property Get AggregateMethodNameDict() As Object
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        
        Dict(xlSum) = "合計"
        Dict(xlCount) = "データの個数"
        Dict(xlAverage) = "平均"
        Dict(xlMax) = "最大値"
        Dict(xlMin) = "最小値"
        Dict(xlProduct) = "積"
        Dict(xlCountNums) = "数値の個数"
        Dict(xlStDev) = "標本標準偏差"
        Dict(xlStDevP) = "標準偏差"
        Dict(xlVar) = "標本分散"
        Dict(xlVarP) = "分散"
        
    Set AggregateMethodNameDict = Dict
End Property

' データ範囲の書式変更
Public Sub SetFormat(Optional format_type As FormatType = ft桁区切り)
    With Pvt.DataBodyRange
        Select Case format_type
            Case ft標準: .NumberFormatLocal = "G/標準"
            Case ft数値: .NumberFormatLocal = "0_);[赤](0)"
            Case ft通貨: .NumberFormatLocal = "\#,##0_);[赤](\#,##0)"
            Case ft会計: .NumberFormatLocal = "_ \* #,##0_ ;_ \* -#,##0_ ;_ \* ""-""_ ;_ @_ "
            Case ft短い日付形式: .NumberFormatLocal = "yyyy/m/d"
            Case ft長い日付形式: .NumberFormatLocal = "[$-F800]dddd, mmmm dd, yyyy"
            Case ft時刻: .NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"
            Case ftパーセンテージ: .NumberFormatLocal = "0%"
            Case ft分数: .NumberFormatLocal = "# ?/?"
            Case ft指数: .NumberFormatLocal = "0.E+00"
            Case ft文字列: .NumberFormatLocal = "@"
            
            Case ft桁区切り: .Style = "Comma [0]"
        End Select
    End With
End Sub

' お気に入り書式盛合せ
Public Sub SetFavoriteFormat()
    ' 表形式で表示。
    SetRowAxisLayout layout_row_type:=xlTabularRow
    
    ' 小計を非表示。
    SetSubTotals subtotal_visible:=False
    
    ' 平均で集計。
    SetValueField xlSum
    
    ' 書式を桁区切りに。
    SetFormat ft桁区切り
End Sub

' フィルター設定。
Public Sub SetFilter(page_fields As Variant, _
                     criteria As String, _
            Optional item_visible As Boolean = True)

    ' フィルターで複数選択を可とする。
    Pvt.PivotFields(page_fields).EnableMultiplePageItems = True
    
    For Each PvtItem In Pvt.PageFields(page_fields).PivotItems
        If PvtItem.Name Like "*" & criteria & "*" Then
            PvtItem.Visible = item_visible
        Else
            PvtItem.Visible = Not item_visible
        End If
    Next
End Sub

' 集計フィールド追加。
Public Function SetCalculatedField(added_name As String, _
                                   added_formula As String) As Excel.PivotField
    Pvt.CalculatedFields.Add added_name, added_formula
    Set SetCalculatedField = Pvt.PivotFields(added_name)
    SetCalculatedField.Orientation = xlDataField
End Function

Public Function SetPersonalTableStyle() As TableStyle
    Dim TableStyle As Excel.TableStyle
    
    ' 作成済みの場合、エラーになる。
        On Error Resume Next
    Set TableStyle = ActiveWorkbook.TableStyles.Add("PersonalTableStyle01")
        If Err.Number <> 0 Then
            Set SetPersonalTableStyle = ActiveWorkbook.TableStyles("PersonalTableStyle01")
            Exit Function
        End If
        
    ' テーブルスタイルを表示して、選択可能にする。
        TableStyle.ShowAsAvailableTableStyle = True
        
    Dim ElementTypeIndex As Variant
    Dim BordersIndex As Variant
    
    ' 以下は個人的好みを反映したものであるため、任意に変更可。
    
    ' 全体と見出し行を設定。
        For Each ElementTypeIndex In Array(xlWholeTable, xlHeaderRow)
            With TableStyle.TableStyleElements.Item(ElementTypeIndex)
            
            ' 一旦すべての罫線を削除する。
                .Borders.LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                
            ' 上下の罫線を設定。
                For Each BordersIndex In Array(xlEdgeTop, xlEdgeBottom)
                    With .Borders(BordersIndex)
                        .ThemeColor = xlThemeColorLight1
                        .TintAndShade = 0.5
                        .Weight = xlThin
                    End With
                Next
            End With
        Next
        
        ' 見出し行の塗りつぶし設定。
        With TableStyle.TableStyleElements.Item(xlHeaderRow)
            With .Interior
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.05
            End With
        End With
        
        Set SetPersonalTableStyle = TableStyle
End Function

' スライサー追加。
Public Function AddedSlicer(source As Variant, _
                            target_label As String, _
                   Optional destination_sheetname As String, _
                   Optional slicer_cache_type As Excel.XlSlicerCacheType = xlSlicer, _
                   Optional timeline_viewstate_level As Excel.XlTimelineLevel = xlTimelineLevelDays, _
                   Optional timeline_start As Date, _
                   Optional timeline_end As Date) As Excel.Slicer
    
    ' スライサーの追加先。
    Dim Sh As Worksheet
        Select Case destination_sheetname
            Case vbNullString
                Set Sh = ActiveSheet
            Case Else
                Set Sh = Sheets(destination_sheetname)
        End Select
    
    ' sourceの型によって処理を変更。
    Dim SourceTable As Variant
        Select Case TypeName(source)
            Case "ListObject", "PivotTable"
                Set SourceTable = source
            Case "Range"
                
                ' sourceがテーブルの一部なのか、ピボットテーブルの一部なのかを判別。
                ' 異なる型で設定するとエラーになるため、一時的にエラーを無視させる。
                On Error Resume Next
                Dim Tb As ListObject: Set Tb = source.ListObject
                Dim Pt As PivotTable: Set Pt = source.PivotTable
                    If Tb Is Nothing Then
                        If Not Pt Is Nothing Then
                            Set SourceTable = Pt
                        Else
                            Exit Function
                        End If
                    Else
                        Set SourceTable = Tb
                    End If
                On Error GoTo 0
            Case Else
                Exit Function
        End Select
    
    ' スライサーキャッシュまでで、一旦変数に格納する（コードの一行が長くなるので）。
    Dim SlicerCache As Excel.SlicerCache
    
    ' スライサーキャッシュの名前が既存のものと重複した場合、自動で末尾に数字が付される（カウントアップ）。
    Set SlicerCache = ActiveWorkbook.SlicerCaches.Add2(SourceTable, target_label, , slicer_cache_type)
                       
    ' スライサーの名前が重複すると、エラーになる。重複を避けるために、名前に年月日_時分秒を追加する。
    Set AddedSlicer = SlicerCache.Slicers.Add(Sh, , target_label & Format(Now, "_yyyymmdd_hhmmss"), target_label)
    
    ' スライサーがタイムラインの場合の設定
        If slicer_cache_type = xlTimeline Then
        
            ' タイムラインのレベルを「年、四半期、月、日」の何れかに設定する。
            AddedSlicer.TimelineViewState.Level = timeline_viewstate_level
            
            ' タイムラインのレベルが「日」である場合に限り、表示の開始日と終了日を設定する。
            ' ※年単位でデータがある場合、無駄に長くなってしまうため。
            If timeline_viewstate_level = xlTimelineLevelDays Then
            
                ' 開始日の指定がない場合、当月一日とする。
                If timeline_start = Empty Then
                    timeline_start = Format(Date, "yyyy/mm/01")
                End If
                
                ' 終了日の指定がない場合、当月最終日とする。
                If timeline_end = Empty Then
                    timeline_end = WorksheetFunction.EDate(timeline_start, 1) - 1
                End If
                
                ' 開始日と終了日の前後関係が逆転している場合、全てのデータが表示される。
                ' そこで大小関係を確認・調整している。
                If timeline_start > timeline_end Then
                    Dim temp As Date: temp = timeline_start
                    timeline_start = timeline_end
                    timeline_end = temp
                End If
                
                ' タイムラインのデータ範囲設定。
                SlicerCache.TimelineState.SetFilterDateRange timeline_start, timeline_end
            End If
        End If
End Function

Private Property Get PvtVersion() As Long
    Select Case CLng(Application.Version)
        ' 2010の場合。
        Case 14
            PvtVersion = xlPivotTableVersion14
        ' 2013の場合。
        Case 15
            PvtVersion = xlPivotTableVersion15
        ' 2016の場合。
        Case 16
            PvtVersion = 6
    End Select
End Property

Private Sub Class_Terminate()
    If Not Pvt Is Nothing Then
        Pvt.TableStyle2 = "PivotStyleLight8"
        With Pvt.TableRange2
            .Font.Name = "メイリオ"
            .Font.Size = 10
            .RowHeight = 20
            .EntireColumn.AutoFit
        End With
    End If
End Sub

今後も修正や追加などあれば、こちらを編集するとしよう。

参考まで。