Option Explicit

Sub PvtTbl_Sample()

'変数の宣言
    Dim DataSht As Worksheet   'データシート
    Dim PvtSht As Worksheet    '集計表シート
    Dim PvtTbl As PivotTable   'ピボットテーブル
    Dim ListNo As Long         'ユーザー設定リストの数
    Dim PvtLabel As Variant    'フィールドラベル
    Dim PvtSelect As Variant   'レイアウトエリアの選択場所
    Dim PvtFld As PivotField   'ピボットフィールド
    Dim PvtItem As PivotItem   'ピボットアイテム
    Dim PvtBorder As Variant   '罫線の位置
    Dim ColorNo1 As Long       '罫線の色１
    Dim ColorNo2 As Long       '罫線の色２
    Dim myYear As String       '日付の表示年
    Dim myMonth As String      '日付の表示月

'シートの準備
    With ThisWorkbook
        On Error Resume Next
        Set DataSht = .Worksheets(1)
        DataSht.Name = "データ"
        Set PvtSht = .Worksheets(2)
        If PvtSht Is Nothing Then
            Set PvtSht = .Worksheets.Add(After:=.Worksheets(1))
        End If
        PvtSht.Name = "集計表"
        PvtSht.Cells.Clear
        On Error GoTo 0

'ピボットテーブル用の書式スタイル（MSゴシック、太字、11ポイント）を作成
        On Error Resume Next
        .Styles("PvtFontStyle").Delete
        On Error GoTo 0
        .Styles.Add Name:="PvtFontStyle"
        With .Styles("PvtFontStyle")
            .IncludeNumber = False
            .IncludeFont = True
            .IncludeAlignment = False
            .IncludeBorder = False
            .IncludePatterns = False
            .IncludeProtection = False
            With .Font
                .Name = "ＭＳ Ｐゴシック"
                .Size = 11
                .Bold = True
            End With
        End With

    End With

'計算方法を手動にする
    Application.Calculation = xlCalculationManual

'サンプルデータを作成する
    With DataSht
        .Cells.Clear
        .Range("A1:E1").Value = Array("入荷日", "入荷地", "品名", "数量", "金額")
        .Range("B2:B1001").Value = _
            "=CHOOSE(MOD(INT(RAND()*10),5)+1,""函館"",""成田"",""横浜"",""神戸"",""門司"")"
        .Range("C2:C1001").Value = _
            "=CHOOSE(MOD(INT(RAND()*10),5)+1,""レモン"",""バナナ"",""パイナップル"",""グレープフルーツ"",""オレンジ"")"
        .Range("D2:D1001").Value = "=INT(((RAND()*10)+1))*10"
        .Range("E2:E1001").Value = "=INT(((RAND()*10)+1))*1000"
        .Range("A1001").Value = Date
        .Range("A1001").AutoFill _
            Destination:=.Range("A802:A1001"), Type:=xlFillWeekdays
        .Range("A802:A1001").Copy _
            Destination:=Application.Union(.Range("A602"), _
                .Range("A402"), .Range("A202"), .Range("A2"))
        With .Range("A:A").SpecialCells(xlCellTypeConstants, 1)
            .Sort Key1:=.Range("A1"), Order1:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                Orientation:=xlTopToBottom, SortMethod:=xlPinYin
            .NumberFormatLocal = "ge.m.d"
        End With
        .Range("A1").CurrentRegion.Name = "Database"
        myYear = Year(Application.WorksheetFunction.Max(.Range("A:A"))) & "年"
        myMonth = Month(Application.WorksheetFunction.Max(.Range("A:A"))) & "月"
    End With

'イベント処理を無効にする
    Application.EnableEvents = False

'ピボットテーブルを作成する
    Set PvtTbl = DataSht.PivotTableWizard(TableDestination:=PvtSht.Range("A1"))
    Set DataSht = Nothing

'フィールドリストを表示させない
    With Application.CommandBars("PivotTable")
        .Visible = True
        If Val(.Parent.Version) >= 10 Then
            ActiveWorkbook.ShowPivotTableFieldList = False
        ElseIf .Controls(13).Caption <> " " Then
            .Controls(10).Execute
        End If
    End With

'ピボットテーブルでの作業
    With PvtTbl

'書式の保持を有効にする
        .PreserveFormatting = True

'============================================================
'最初のレイアウトを設定する
        .AddFields RowFields:="品名", ColumnFields:="入荷地"

'画面の更新を止める
'    Application.ScreenUpdating = False

'ピボットテーブルの範囲に"PvtFontStyle"を適用する
        .PivotSelect "", xlDataAndLabel
        Selection.Style = "PvtFontStyle"

'数量をデータエリアに配置する
        With .PivotFields("数量")
            .Orientation = xlDataField
            .Caption = "数量合計"
            .Function = xlSum
            .NumberFormat = "#,##0_ "
        End With

'入荷地をユーザー設定で並べ替える
        On Error Resume Next
        Application.AddCustomList _
            ListArray:=Array("函館", "成田", "横浜", "神戸", "門司")
        On Error GoTo 0
        ListNo = Application.CustomListCount
        .ColumnRange.Sort Order1:=xlAscending, _
            Type:=xlSortLabels, OrderCustom:=ListNo + 1, _
            Orientation:=xlLeftToRight, SortMethod:=xlStroke
        Application.DeleteCustomList ListNum:=ListNo

'罫線に使う色の設定
        ColorNo1 = 7 'ピンク（普通の実線に適用）
        ColorNo2 = 1 '黒（太目の実線に適用）

'表示フィールドのデータ及びラベルエリアに対して罫線を引く
        For Each PvtFld In .VisibleFields
            For Each PvtItem In PvtFld.PivotItems
                .PivotSelect PvtItem, xlDataAndLabel
                For Each PvtBorder In Array(xlEdgeBottom, xlEdgeRight)
                    With Selection.Borders(PvtBorder)
                        .Weight = xlThin
                        .ColorIndex = ColorNo1
                    End With
                Next PvtBorder
            Next
        Next

'============================================================
'レイアウトを変更する
        .AddFields RowFields:=Array("入荷日", "品名"), _
                                    ColumnFields:="入荷地"

'各ラベルのラベルエリアとデータエリアに対して太線を引く
        For Each PvtLabel In Array("", "入荷地[All]", _
                "品名[All]", "入荷日[All]", _
                "'Row Grand Total'", "'Column Grand Total'")
            For Each PvtSelect In Array(xlLabelOnly, xlDataOnly)
                .PivotSelect PvtLabel, PvtSelect
                For Each PvtBorder In Array(xlEdgeLeft, _
                        xlEdgeTop, xlEdgeBottom, xlEdgeRight)
                    With Selection.Borders(PvtBorder)
                        .Weight = xlMedium
                        .ColorIndex = ColorNo2
                    End With
                Next PvtBorder
            Next PvtSelect
        Next PvtLabel

        .PivotSelect "", xlOrigin
        With Selection.Borders(xlEdgeBottom)
            .Weight = xlMedium
            .ColorIndex = ColorNo2
        End With

'各ラベルの書式設定をする
        For Each PvtLabel In Array("入荷地[All]", "入荷日[All]", "品名[All]")
            .PivotSelect PvtLabel, xlDataOnly
            Selection.Interior.ColorIndex = 35 '薄い緑
        Next PvtLabel

        .PivotSelect "入荷地[All]", xlLabelOnly
        Selection.Interior.ColorIndex = 15 '25% 灰色
        Selection.Font.ColorIndex = 41 '薄い青

        .PivotSelect "品名[All]", xlLabelOnly
        Selection.Interior.ColorIndex = 50 'シーグリーン
        Selection.Font.ColorIndex = 2 '白

        .PivotSelect "入荷日[All]", xlLabelOnly
        Selection.Interior.ColorIndex = 36 '薄い黄色

'総計エリアの書式設定をする
        For Each PvtLabel In Array("'Column Grand Total'", _
                                        "'Row Grand Total'")
            .PivotSelect PvtLabel, xlDataAndLabel
            Selection.Interior.ColorIndex = 44 'ゴールド

            .PivotSelect PvtLabel, xlDataOnly
            Selection.Font.ColorIndex = 41 '薄い青

            .PivotSelect PvtLabel, xlLabelOnly
            Selection.HorizontalAlignment = xlCenter
        Next PvtLabel

'入荷日の集計行に書式設定する
        .PivotSelect "入荷日[All;Total]", xlDataAndLabel
        Selection.Interior.ColorIndex = 2 '白
        Selection.Font.ColorIndex = 1 '黒

'============================================================
'レイアウトを変更する
        .PivotFields("入荷地").Orientation = xlRowField

'罫線の補正とラベルの書式設定をする
        For Each PvtLabel In Array("入荷地[All]", "品名[All;Total]")
            .PivotSelect PvtLabel, xlLabelOnly
            For Each PvtBorder In Array(xlEdgeLeft, xlEdgeBottom)
                With Selection.Borders(PvtBorder)
                    .Weight = xlMedium
                    .ColorIndex = ColorNo2
                End With
            Next PvtBorder
        Next PvtLabel

        .PivotSelect "入荷日[All;Total]", xlDataOnly
        With Selection.Borders(xlEdgeTop)
            .Weight = xlMedium
            .ColorIndex = ColorNo2
        End With

'背景色とフォント色を変更する
        .PivotSelect "品名[All;Total]", xlDataAndLabel
        With Selection
            .Interior.ColorIndex = 34 '水色
            .Font.ColorIndex = 10 '緑
        End With

'============================================================
'レイアウトを変更する
'行フィールドの"品名"と"入荷地"表示位置を入れ替える
        With .PivotFields("品名")
            .Orientation = xlRowField
            .Position = 3
        End With

'罫線の補正とラベルの書式設定をする
        .PivotSelect "入荷地[All;Total]", xlDataAndLabel
        With Selection
            For Each PvtBorder In Array(xlEdgeLeft, xlEdgeBottom)
                With .Borders(PvtBorder)
                    .Weight = xlMedium
                    .ColorIndex = ColorNo2
                End With
            Next PvtBorder
            .Interior.ColorIndex = 2  '白
            .Font.ColorIndex = 3 '赤
        End With

'============================================================
'レイアウトを変更する
'入荷地フィールドを行エリアに残し、品名フィールドを列エリアへ移動する
        .PivotFields("品名").Orientation = xlColumnField

'罫線の補正とラベルの書式設定をする
        .PivotSelect "入荷日[All;Total]", xlDataOnly
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = 1
        End With
        .PivotSelect "'Row Grand Total'", xlDataAndLabel
        With Selection.Borders(xlEdgeLeft)
            .Weight = xlMedium
            .ColorIndex = ColorNo2
        End With

'============================================================
'レイアウトを変更する
        .AddFields RowFields:=Array("入荷日", "品名"), _
                                    ColumnFields:="入荷地"

'日付をグループ化させて集計
'処理の内容：入荷日を月と年でグループ化させ、最新月のみ絞り込んで集計する

'日付をグループ化する
        .TableRange1.Range("A2").Group _
            Start:=True, End:=True, Periods:=Array(False, _
                False, False, True, True, False, True)

'グループ化した年と月をページエリアに移動する
        .PivotFields("月").Orientation = xlPageField
        .PivotFields("年").Orientation = xlPageField

'年と月の非表示アイテムを設定し、表示アイテムを指定する
        With .PivotFields("年")
            .PivotItems(1).Visible = False
            .PivotItems(.PivotItems.Count).Visible = False
            .CurrentPage = myYear
        End With
        With .PivotFields("月")
            .PivotItems(1).Visible = False
            .PivotItems(.PivotItems.Count).Visible = False
            .CurrentPage = myMonth
        End With

'処理終了
        .TableRange1.Range("A1").Select

'イベント処理を有効にし、自動計算モードにする
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic

'ピボットテーブルを更新する
        .RefreshTable

    End With

'オブジェクト変数の解放
    Set PvtTbl = Nothing
    Set PvtSht = Nothing

'画面表示を更新する
    'Application.ScreenUpdating = True

End Sub