趣味プログラミングblog

---

１次元の集計では、頻度順に並べることが多いので、その名残で２次元の集計も頻度順がデフォルト。
けど、日時に関するデータなんかは項目順に並べるほうが見やすい。という分けでマクロを作った次第。

縦横のうち片方だけ項目順とかありえるかなと思って
それぞれの軸に対してメッセージボックスを表示して、並べ替え方法を確認（vbYesNoCancel)

---

処理の流れ

'件数範囲（左上と右下の番号を取得）

'タイトル抽出してメッセージボックスを表示

'ｘ軸用ソート　昇順の場合は2行目をKeyに、降順の場合は1行目をKeyにする。

'列の並べ替え はソートオブジェクトを使う

'ｙ軸用ソート　昇順の場合はB列をKeyに、降順の場合は最終列の次の列（合計列）をKeyにする。

'行の並べ替え はオートフィルタオブジェクト（対象範囲の指定はない）

---

実行結果










以下、ソース。モジュールテキストは こちら。

---

Sub ◆2列集計結果の再ソート()

'件数範囲 左上と右下
Dim stRow As Long: stRow = 3
Dim stCol As Long: stCol = 3
Dim edRow As Long: edRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim edCol As Long: edCol = Cells(2, Columns.Count).End(xlToLeft).Column - 1

'タイトル抽出
Dim strBuf: strBuf = Split(Cells(1, "B"), "×")
Dim strX As String: strX = strBuf(0)
Dim strY As String: strY = strBuf(1): strY = Left(strY, InStr(strY, "」"))

Dim RC As Long, msg As String

'y軸用メッセージを出して、ソート
msg = "y軸" & strY & "を昇順に再ソートします。" & Chr(10) & "はい：項目昇順　、　いいえ：カウント降順" '●
RC = MsgBox(msg, vbYesNoCancel)

Dim vOrder As Long '並び順 XY共通
Dim rOffset As Long 'Keyの位置

If RC = vbYes Then '昇順
vOrder = xlAscending '1:昇順
rOffset = 1
ElseIf RC = vbNo Then '降順
vOrder = xlDescending ' 2:降順
rOffset = 2
End If

Dim keyRange As range, tarRange As range

'列の並べ替え はソートオブジェクト
If RC <> vbCancel Then
Set keyRange = range(Cells(stRow - rOffset, stCol), Cells(stRow - rOffset, edCol))
Set tarRange = range(Cells(stRow - 2, stCol), Cells(edRow, edCol))

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add key:=keyRange, SortOn:=xlSortOnValues, Order:=vOrder, DataOption:=xlSortNormal
.SetRange tarRange
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
End If

'x軸用メッセージを出して、ソート
msg = "x軸" & strX & "を昇順に再ソートします。" & Chr(10) & "はい：項目昇順　、　いいえ：カウント降順" '●
RC = MsgBox(msg, vbYesNoCancel)
'xはオートフィルタ範囲をソートなのでレンジ設定は要らない

Dim keyCol As Long
If RC = vbYes Then '昇順
vOrder = xlAscending '1 既定値。昇順に並べ替えます
keyCol = 2
ElseIf RC = vbNo Then '降順
vOrder = xlDescending ' 2 降順に並べ替えます
keyCol = edCol + 1
End If

'行の並べ替え はオートフィルタオブジェクト
If RC <> vbCancel Then
Set keyRange = range(Cells(stRow, keyCol), Cells(edRow, keyCol))
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add key:=keyRange, SortOn:=xlSortOnValues, Order:=vOrder, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If

End Sub

---

関連記事
「お気に入りの集計マクロ」

「列集計マクロの改良」

「エクセルの列ソート」