フィールドの並べ替えの設定で望みどおりの結果にならない

今回は、行エリアや列エリアに置いたフィールドの並べ替えの設定で望みの結果にならないことについて書いてみたいと思います。

それは、行（列）フィールドに並べ替えの設定をする時、基準とするフィールドにデータフィールドを指定した時に起きることがあります。

例えば、PvtTblSort5_Layout1 で作成されるような行エリアに一つ、データエリアに一つのフィールドを置いたレイアウトのピボットテーブルがあるとします。"項目" フィールドに対して並べ替えの設定をしていない時は、規定値である文字コードの順に A,B,C,D,E,F,G と並びます。

次に、PvtTblSort5_Layout2 を実行して "項目" フィールドに対してデータフィールドである "数値計" を並べ替えの基準に設定をしたピボットテーブルを作成します。そうすると、同じ結果の数値がある場合、その数値の固まりの "項目" フィールドのアイテムは、A,B,C,…、という並びではなく、まったくデタラメな並びになります。今回のサンプルデータは、数値部分を関数のままにしているので "月" フィールドのアイテムを変えるだけでなく、［更新］ボタンで結果を変えても "項目" フィールドがデタラメな並びになることが確認できると思います。

並びが異なる理由（どういう仕様？バグ？）は、分かりませんが、「データ＞並べ替え」で複数の条件が設定できるように、ピボットテーブルの並べ替えの機能でも、複数の条件が設定できるといいと思いませんか？

私は、単一のピボットテーブルで他に比較する表がなければ、並びがデタラメでもそのまま使うことがあるのですが、「ページの表示」で展開して一覧表を作るような処理をした時は、とても使えたものではないと思っています。

ということで、こういう場合は、フィールドの並べ替えの設定を使わずに該当する範囲を指定して「データ＞並べ替え」を使って処理しています。

　◇　◇　◇　◇　◇

サンプルマクロの説明ですが、PvtTblSort5_Layout1 が今回の基本のピボットテーブルです。行エリアに "項目"、データエリアに "数値"、ページエリアに "日付" をグループ化した "月" を置いています。PvtTblSort5_Layout2 は、PvtTblSort5_Layout1を呼び出した後、"項目" フィールドに対して "数値計" の降順に並べ替えの設定をしています。

Sub PvtTblSort5_Layout1()
'サンプルデータ及びピボットテーブルを作成する

　　Const myCount = 101
　　Dim myData(1 To myCount, 1 To 3) As Variant
　　Dim i As Long
　　Dim DataSht As Worksheet
　　Dim PvtSht As Worksheet
　　Dim FldName As Variant

'サンプルデータの作成、入力
　　myData(1, 1) = "日付"
　　myData(1, 2) = "項目"
　　myData(1, 3) = "数値"
　　For i = 2 To myCount
　　　　myData(i, 1) = DateSerial(Year(Date), _
　　　　　　Int((12 * Rnd) + 1), Int((31 * Rnd) + 1))
　　　　myData(i, 2) = WorksheetFunction.Choose(Int((7 * Rnd) + 1), _
　　　　　　"A", "B", "C", "D", "E", "F", "G")
　　　　myData(i, 3) = "=INT(RAND()*2)"
　　Next i
　　With ActiveWorkbook
　　　　On Error Resume Next
　　　　Set DataSht = .Worksheets("PvtData")
　　　　On Error GoTo 0
　　　　If DataSht Is Nothing Then
　　　　　　Set DataSht = .Worksheets.Add(Before:=.Worksheets(1))
　　　　　　DataSht.Name = "PvtData"
　　　　Else
　　　　　　With DataSht.Cells
　　　　　　　　.Clear
　　　　　　　　.ColumnWidth = .Parent.StandardWidth
　　　　　　　　Application.Goto Reference:=.Item(1), Scroll:=True
　　　　　　End With
　　　　End If
　　　　On Error Resume Next
　　　　Set PvtSht = Worksheets("PvtSht")
　　　　On Error GoTo 0
　　　　If PvtSht Is Nothing Then
　　　　　　Set PvtSht = Worksheets.Add
　　　　　　PvtSht.Name = "PvtSht"
　　　　Else
　　　　　　With PvtSht.Cells
　　　　　　　　.Clear
　　　　　　　　.ColumnWidth = .Parent.StandardWidth
　　　　　　　　Application.Goto Reference:=.Item(1), Scroll:=True
　　　　　　End With
　　　　End If
　　End With
　　With DataSht
　　　　.Range("A1:C1").HorizontalAlignment = xlCenter
　　　　Application.Goto Reference:=.Range("A2")
　　　　ActiveWindow.FreezePanes = True
　　　　.Range("A1").Resize(UBound(myData) - 1, _
　　　　　　1).Offset(1).NumberFormatLocal = "ge.m.d"
　　　　With .Range("A1").Resize(UBound(myData), 3)
　　　　　　.ClearContents
　　　　　　.Value = myData
　　　　　　.EntireColumn.AutoFit
　　　　　　.Name = "Database"
　　　　End With
　　　　Erase myData
　　End With

'ピボットテーブルを作成する
　　With ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
　　　　SourceData:="Database").CreatePivotTable( _
　　　　　　TableDestination:="PvtSht!R3C1")
　　　　.NullString = "0"
　　　　.AddFields RowFields:="日付"
　　　　With .PivotFields("数値")
　　　　　　.Orientation = xlDataField
　　　　　　.Caption = "数値計"
　　　　End With
　　　　.PivotFields("日付").LabelRange.Group _
　　　　　　Periods:=Array(False, False, False, True, True, False, False)
　　　　For Each FldName In Array("日付", "月")
　　　　　　With .PivotFields(FldName)
　　　　　　　　.PivotItems(1).Visible = False
　　　　　　　　.PivotItems(.PivotItems.Count).Visible = False
　　　　　　End With
　　　　Next FldName
　　　　.AddFields RowFields:="項目", PageFields:="月"
　　　　.PivotFields("項目").ShowAllItems = True
　　　　Application.Goto Reference:=.TableRange2.Range("A1")
　　End With

End Sub

---

Sub PvtTblSort5_Layout2()
'PvtTblSort5_Layout1 を呼び出してピボットテーブルを作成する

　　Call PvtTblSort5_Layout1

　　'"項目"フィールドに対して "数値計" を基準に降順設定する
　　ActiveSheet.PivotTables(1).PivotFields("項目").AutoSort _
　　　　 Order:=xlDescending, Field:="数値計"

End Sub

　◇　◇　◇　◇　◇

私としては、PvtTblSort5_Layout2 のような結果になる場合は、問題ありと思っていまして、"項目" フィールドも望みどおりの並べ替えをしたいので、PvtTblSort5_EventSort のようなマクロを組んで、ピボットテーブルの機能ではない「データ＞並べ替え」の処理を実行させて望みどおりの結果になるように並べ替えをします。

この並べ替えの処理は、行フィールドのラベルエリアを指定して並べ替え、次に、行フィールドのラベルエリアとデータエリアの範囲を指定して並べ替えています。処理のポイントは、２回目の並べ替えの処理をする時の Key1 に設定する範囲にデータエリアのセルを指定することです。データエリアのセルを指定しないとエラーになるので注意してください。

また、日付のグループ化で作成された"月"を行エリアに配置して並べ替える時は、データ＞並べ替えでは、10月,11月,12月,1月,… のように並べ替えられてしまうので、フィールドの設定による昇順並べ替えを使うといいと思います。

なお、ピボットテーブルに対して処理する時は、シートモジュールやブックモジュールのイベントプロシージャで PvtTblSort5_EventSort を呼び出して利用するといいと思います。

イベントプロシージャを利用してでサンプルマクロを確認するには、ピボットテーブルのあるシートモジュールに Worksheet_Calculate（XL2000以降）、又は、 Worksheet_PivotTableUpdate（XL2002以降）の処理をコピペして確認してみてください。

ただ、ピボットテーブルの状態で行エリアとデータエリアを指定しての並べ替え処理は、残念なことに XL2007 では、できなくなってしまったようです。

Sub PvtTblSort5_EventSort(Optional PvtTbl As PivotTable)
'イベント処理から呼び出される処理
'行フィールドを並べ替えてからデータエリアを含む範囲を並べ替える

　　Dim FldName As String
　　Dim VarItem As Variant

'引数 PvtTbl の指定がない時は、
'アクティブシートの Index が 1 のピボットテーブルを指定
　　If PvtTbl Is Nothing Then
　　　　On Error Resume Next
　　　　Set PvtTbl = ActiveSheet.PivotTables(1)
　　　　On Error GoTo 0
　　End If

'ピボットテーブルがあった時は、以下の処理
　　If Not PvtTbl Is Nothing Then
　　　　With PvtTbl
　　　　　　'(行)フィールドが１つなら処理
　　　　　　If .RowFields.Count = 1 Then
　　　　　　　　FldName = .RowFields(1).Name
　　　　　　　　'"月"フィールドなら
　　　　　　　　If FldName = "月" Then
　　　　　　　　　　　　'昇順で並べ替えをして
　　　　　　　　　　　　.RowFields(1).AutoSort xlAscending, FldName
　　　　　　　　　　　　'手動で並べ替えにする
　　　　　　　　　　　　.RowFields(1).AutoSort Order:=xlManual, Field:=FldName
　　　　　　　　'"項目"フィールドなら
　　　　　　　　ElseIf FldName = "項目" Then
　　　　　　　　　　　　'手動で並べ替えにして
　　　　　　　　　　　　.RowFields(1).AutoSort Order:=xlManual, Field:=FldName
　　　　　　　　　　　　'(行)フィールドのラベルのみ選択して並べ替える
　　　　　　　　　　　　.RowFields(1).LabelRange.Sort Order1:=xlAscending, _
　　　　　　　　　　　　　　Type:=xlSortLabels, OrderCustom:=1, _
　　　　　　　　　　　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin
　　　　　　　　End If
　　　　　　　　Select Case FldName
　　　　　　　　　　'月と項目フィールドなら
　　　　　　　　　　Case "月", "項目"
　　　　　　　　　　　　'ラベルとデータを選択して並べ替え
　　　　　　　　　　　　'（Key1にデータエリアのセルを指定すること）
　　　　　　　　　　　　.PivotSelect FldName & "[All]", xlDataAndLabel
　　　　　　　　　　　　Selection.Sort Key1:=.DataBodyRange.Range("A1"), _
　　　　　　　　　　　　　　Order1:=xlDescending, Type:=xlSortValues, OrderCustom:=1, _
　　　　　　　　　　　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin
　　　　　　　　　　Case Else
　　　　　　　　　　　　'上記項目以外は処理なし
　　　　　　　　End Select
　　　　　　　　Application.Goto Reference:=.TableRange2.Range("A1")
　　　　　　End If
　　　　End With
　　End If

　　Set PvtTbl = Nothing

End Sub

---

Private Sub Worksheet_Calculate()
'ピボットテーブルのあるシートモジュールに記述（XL2000以降）
　　Application.EnableEvents = False
　　Call PvtTblSort5_EventSort
　　Application.EnableEvents = True
End Sub

---

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'ピボットテーブルのあるシートモジュールに記述（XL2002以降）
　　Application.EnableEvents = False
　　Call PvtTblSort5_EventSort(PvtTbl:=Target)
　　Application.EnableEvents = True
End Sub

　◇　◇　◇　◇　◇

最後の PvtTblSort5_ShowPage は、PvtTblSort5_Layout2 を呼び出して作成したピボットテーブルの各月の一覧表を作成します。上段の表は、問題ありの一覧表、下段の表は、データ＞並べ替えを使って "項目" も並べ替えた表です。第三者に見てもらう表としては、下段の表の方が説明しやすいと思いますが皆さんはどう思われるでしょうか？

Sub PvtTblSort5_ShowPage()
'ピボットテーブルの機能で並べ替えた一覧表と、
'後から並べ替えをした表の比較

　　Dim PvtBook As Workbook
　　Dim PvtSht As Worksheet
　　Dim PvtTbl As PivotTable
　　Dim myBorder As Variant　　
　　Dim mySht As Worksheet
　　Dim CopyCount As Long
　　Dim CopyColumn As Long
　　Dim CopyRange As Range
　　Dim FirstAddr As String
　　Dim Target As Range

　　Application.EnableEvents = False

'"項目"フィールドを"数値計"フィールドを基準に並べ替え設定したピボットテーブルを作成
'（PvtTblSort5_Layout2を利用）
　　Call PvtTblSort5_Layout2
　　Set PvtSht = ActiveSheet

'新規ブックにコピー、各変数にオブジェクトを設定
　　PvtSht.Copy
　　Set PvtBook = ActiveWorkbook
　　Set PvtSht = PvtBook.ActiveSheet
　　Set PvtTbl = PvtSht.PivotTables(1)
　　PvtTbl.Format xlPTNone　'オートフォーマットなし

'書式設定をする（スタイルの作成、適用と罫線の設定）
　　PvtBook.Styles.Add Name:="NewStyle"
　　With PvtBook.Styles("NewStyle")
　　　　.IncludeNumber = False
　　　　.IncludeFont = False
　　　　.IncludeAlignment = False
　　　　.IncludeBorder = True
　　　　.IncludePatterns = True
　　　　.IncludeProtection = False
　　　　.Interior.ColorIndex = 0
　　　　For Each myBorder In Array(xlTop, xlBottom, xlLeft, xlRight)
　　　　　　.Borders(myBorder).Weight = xlHairline
　　　　Next myBorder
　　End With
　　With PvtTbl
　　　　.PivotSelect "", xlDataAndLabel
　　　　Selection.Style = "NewStyle"
　　　　PvtBook.Styles("NewStyle").Delete
　　　　For Each myBorder In Array( _
　　　　　　　　xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight)
　　　　　　Selection.Borders(myBorder).Weight = xlThin
　　　　Next myBorder
　　　　.PivotSelect "", xlDataOnly
　　　　For Each myBorder In Array(xlEdgeTop, xlEdgeLeft)
　　　　　　Selection.Borders(myBorder).Weight = xlThin
　　　　Next myBorder
　　　　.PivotSelect "", xlLabelOnly
　　　　For Each myBorder In Array(xlEdgeLeft, xlEdgeRight)
　　　　　　Selection.Borders(myBorder).Weight = xlThin
　　　　Next myBorder
　　　　.PivotSelect "'Column Grand Total'", xlDataAndLabel
　　　　Selection.Borders(xlEdgeTop).Weight = xlThin
　　　　.PivotSelect "項目", xlButton
　　　　Selection.Borders(xlEdgeBottom).Weight = xlThin

'「ページの表示」で1月〜12月毎に集計する
　　　　.ShowPages PageField:="月"
　　End With
　　Set PvtTbl = Nothing

'元のピボットテーブルを削除する
　　With PvtSht.Cells
　　　　.Clear
　　　　.EntireColumn.ColumnWidth = .Parent.StandardWidth
　　End With

'元のピボットテーブルのあったシートに1月〜12月までの一覧表を作成する
'（同様の処理を前に書いているので処理の説明は、割愛します。<(_ _)>）
　　CopyCount = 0
　　For Each mySht In PvtBook.Worksheets

　　　　If mySht.Name <> PvtSht.Name Then
　　　　　　With mySht.PivotTables(1).TableRange1
　　　　　　　　.SpecialCells(xlCellTypeConstants, 2).HorizontalAlignment = xlCenter
　　　　　　　　.Copy
　　　　　　End With
　　　　　　CopyCount = CopyCount + 1
　　　　　　With PvtSht
　　　　　　　　If CopyCount = 1 Then
　　　　　　　　　　CopyColumn = .Cells(2, _
　　　　　　　　　　　　　　　　.Columns.Count).End(xlToLeft).Column
　　　　　　　　Else
　　　　　　　　　　CopyColumn = .Cells(2, _
　　　　　　　　　　　　　　　　.Columns.Count).End(xlToLeft).Column + 2
　　　　　　　　End If
　　　　　　　　With .Cells(2, CopyColumn)
　　　　　　　　　　.PasteSpecial Paste:=xlPasteFormats
　　　　　　　　　　.PasteSpecial Paste:=xlPasteValues
　　　　　　　　　　.Offset(-1).Value = mySht.Name
　　　　　　　　　　If mySht.Name <> "12月" Then
　　　　　　　　　　　　.End(xlToRight).Offset(0, _
　　　　　　　　　　　　　　1).EntireColumn.ColumnWidth = 1
　　　　　　　　　　Else
　　　　　　　　　　　　'12月までコピーしたらコピー範囲の取得
　　　　　　　　　　　　Set CopyRange = PvtSht.Range(.End(xlDown).End(xlToRight), _
　　　　　　　　　　　　　　PvtSht.Range("A1"))
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　End With
　　　　　　Application.DisplayAlerts = False
　　　　　　mySht.Delete
　　　　　　Application.DisplayAlerts = True
　　　　End If
　　Next mySht

'列幅を調整して、作成した一覧表を下の余白にコピー
　　With PvtSht.Range("A1")
　　　　.SpecialCells(xlCellTypeConstants, 23).EntireColumn.AutoFit
　　　　CopyRange.Copy
　　　　.End(xlDown).Offset(2).PasteSpecial Paste:=xlPasteAll
　　　　Set CopyRange = Selection
　　End With
　　Application.CutCopyMode = False

'貼り付けた範囲で "項目" を探しながら、"項目"と"数値形"の範囲を並べ替え
　　Set Target = CopyRange.Find(What:="項目", After:=ActiveCell, LookIn:=xlFormulas)
　　If Not Target Is Nothing Then
　　　　FirstAddr = Target.Address
　　　　Do
　　　　　　With Target.CurrentRegion
　　　　　　　　.Resize(.Rows.Count - 2).Offset(1).Sort _
　　　　　　　　　　Key1:=Target.Offset(, 1), Order1:=xlDescending, _
　　　　　　　　　　Key2:=Target, Order2:=xlAscending, Header:=xlGuess, _
　　　　　　　　　　OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　　　SortMethod:=xlPinYin
　　　　　　End With
　　　　　　Set Target = CopyRange.FindNext(Target)
　　　　Loop While Not Target Is Nothing And Target.Address <> FirstAddr
　　End If
　　Set CopyRange = Nothing
　　Set Target = Nothing

　　Application.Goto Reference:=PvtSht.Range("A1"), Scroll:=True
　　Application.EnableEvents = True

　　Set PvtSht = Nothing

End Sub