ピボットテーブルの備忘録　⑥テーブルに加えて範囲の指定でもピボットテーブルを作成可とする

先日から、マクロによるピボットテーブルの扱いを纏めている（備忘録）。
最初の頃、テーブルを引数にピボットテーブルを作成するマクロに挑戦した。
infoment.hatenablog.com

しかし考えてみると、いつもテーブルが準備されているとは限らない。
そこで今回は、指定した範囲からピボットテーブルを作成することに挑戦する。
f:id:Infoment:20200326200920p:plain

データソースとして範囲を指定する方法もある。しかし私は、テーブルを積極的に使いたいと考えているため、次のステップを踏むことにした。

引数の型を、ListObjectからValiantに変更する。
受け取った引数のタイプを調べる。
ListObjectなら、そのままピボットテーブルを作成する。
Rangeなら、Rangeに紐づくListObjectでテーブルを作成。
Rangeに紐づくListObjectが存在しないなら、Rangeから得られるCurrentRegion範囲をテーブル化したのち、ピボットテーブルを作成する。

このテーブル化のために、昨日の試みを行った次第。
infoment.hatenablog.com

マクロについては、このように修正してみた。

' ピボットテーブル作成。
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"
            
                ' 範囲に設定されたテーブルをSourceTableにセット。
                Set SourceTable = source.ListObject
                
                ' テーブルが存在しない場合、選択範囲から得られるCurrentRegionの範囲を
                ' テーブルに置き換える。
                If SourceTable Is Nothing Then
                    Set SourceTable = source.Parent.ListObjects.Add(xlSrcRange, source.CurrentRegion, , xlYes)
                        With SourceTable
                            .Name = "Table_" & Format(Now, "yyyymmdd_hhmmss")
                            .TableStyle = SetPersonalTableStyle
                            With .Range.Cells
                                .Font.Name = "メイリオ"
                                .Font.Size = 10
                                .RowHeight = 20
                                .EntireColumn.AutoFit
                            End With
                        End With
                End If
        End Select
    
    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