ピボットテーブル作成用に、クラスモジュールを作成してみた。
私的利用向けであるため、汎用性はさほど高くない。とりあえず備忘録として、こちらにまとめておく。
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
今後も修正や追加などあれば、こちらを編集するとしよう。
参考まで。