ピボットテーブルの備忘録　⑧受け取った配列を、一旦新規作成したシートに貼り付けてテーブル化し、そのテーブルからピボットテーブルを作成する

先日から、マクロによるピボットテーブルの扱いを纏めている（備忘録）。
昨日は、指定した範囲を一旦テーブル化し、そのテーブルからピボットテーブルを作成するサブプロシージャの中から、指定範囲をテーブル化する箇所だけを抜き出して関数にしてみた。
infoment.hatenablog.com

今日は、昨日の続きから。
f:id:Infoment:20200329200527j:plain

昨日、テーブル化する箇所を関数として抜き出したのには、理由がある。それは、

受け取った配列を、一旦新規作成したシートに貼り付けてテーブル化し、そのテーブルからピボットテーブルを作成する

という空中技を実現するため。早速、機能拡張してみた。

' ピボットテーブル作成。
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
            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

指定した範囲が作成済みのテーブルである場合、そのテーブルを戻り値とするよう変更してある。

早速、テストしてみた。

Sub Test2()

    Dim arr As Variant
        arr = ActiveSheet.UsedRange

    With New PvtTable
        If .MakePivotTable(arr) = False Then
            MsgBox "ピボットテーブルの作成に失敗しました。"
            Exit Sub
        Else
            ' 各フィールドを設定。
            .SetFields xlPageField, "カレーの食べ方", "キャリア"
            .SetFields xlRowField, "都道府県", "性別"
            .SetFields xlColumnField, "婚姻"
            .SetFields xlDataField, 6
            
            .SetFilter "カレーの食べ方", "左ルー"
            
            .SetFavoriteFormat
        End If
    End With
End Sub