ピボットテーブル作成用クラスモジュール
ピボットテーブル作成用に、クラスモジュールを作成してみた。
私的利用向けであるため、汎用性はさほど高くない。とりあえず備忘録として、こちらにまとめておく。
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」が「0番目」である場合、すべての ' データフィールドの集計方法を統一する。 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
今後も修正や追加などあれば、こちらを編集するとしよう。
参考まで。