エクセルで多項目の並べ替えをしたい

質問

エクセルのワークシートで、１０項目程度の並べ替えをするコマンドボタンを作りたいと思います。

マクロ記録からしか作れなかったので、
Selection.Sort Key1:=Range("G8"), Order1:=xlDescending, Key2:=Range("B8")・・・・・・、
のようになり、
Key4以上設定しよとするとエラーになってしまいます。
Key１０:=ぐらいまで設定したいのですが、どのように記述すれば可能になるでしょうか。

回答No.6

Wendy02 · ベストアンサー

こんばんは。

今、私の考えは、どこまであっているのか分かりませんが、
>最初の★★★★★は揃うのですが、次巡からうまくいきません。
>>個人評価＞a社＞b社＞c社の順に並べ替えたいのです

ひとつだけはっきりしているのは、並べ替える順序が、逆さになっています。

>A列　　B列　　 C列　　　　D列　　 　　　E列
>a社　　 b社　 　c社　　　　個人評価　　　書名

D列を主にするのなら、これが並べ替えで一番最後にするということです。
つまり、★をいったん行をまとめたら、それぞれを並べ替えて、また、★の部分で並べ替えをするということをするわけです。

個人評価＞a社＞b社＞c社

とするなら、

c社-> b社 -> a社　->個人評価です。

つまり、
#5 のコードの場合は、

For Each i In Array(2, 3, 4, 6, 5, 1, 10, 8, 9, 11, 12, 13, 14, 15)

ではなくて、

For Each i In Array(15, 14, 13, 12, 11, 9, 8, 10, 1, 5, 6, 4, 3, 2, 7)
と最後に、7の部分を持ってくるわけです。

お礼

度々のご回答まことにありがとうございました。
For Each i In Arrayや、with～end withの使い方が初めてだったのと、
自分で書いた不注意な記述を見逃していたりして手間取りましたが、教えていただいたことを基盤にして、やっと12列分全てを好きなように並べ替えることができました。（色々やっているうちに並べ替えの順序を大分変更しました。）
持っている本の整理をしたかったのですが、一段落つきました。
心より感謝いたします。

何か無駄なコードも含まれているような気もするのですが、取り合えず完成した式を補足欄にご報告させていただきます。
また質問させていただくこともあるかと思いますが、その折にはよろしくお願いいたします。

補足

Private Sub CommandButton1_Click()

Dim r1 As Long
Dim r2 As Long
Dim r3 As Long
Dim gx1 As Long
Dim y As Variant
Dim i As Variant
Dim k As Variant
Dim Incline As Integer

Incline = xlDescending '降順 , 'xlAscending　'昇順
r1 = ActiveSheet.Range("H65536").End(xlUp).Row

Application.ScreenUpdating = False
With ActiveSheet
With .Range(.Cells(7, 1), .Cells(r1, 12))
.Sort _
Key1:=.Cells(2, 7), _
Order1:=Incline, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With

gx1 = 1
y = 8
Do
Do
If gx1 = 1 Then
r2 = 7
Else
r2 = y
End If

For k = y To r1
If y = r1 Then
Application.ScreenUpdating = True
Exit Sub
End If

If Cells(k, 7).Value = "" Then
r3 = r1
Exit For
End If

If Cells(k, 7).Value <> Cells(k + 1, 7).Value Then
Exit For
End If
Next k
r3 = k
Exit Do
Loop

For Each i In Array(10, 12, 10, 1, 5, 6, 4, 3, 2, 8, 9, 11)
With .Range(.Cells(r2, 1), .Cells(r3, 12))
If i = 7 Or i = 11 Then
Incline = xlDescending
Else
Incline = xlAscending
End If

.Sort _
Key1:=.Cells(2, i), _
Order1:=Incline, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With
Next i

If r3 = r1 Then
Exit Do
End If
gx1 = gx1 + 1
y = k + 1
Loop
End With
Application.ScreenUpdating = True

End Sub

回答No.5

Wendy02

こんばんは。

何か、話が並べ替えというような単純な内容ではないようですね。これは、とてもややこしいです。何か、最初の質問では、想像もつかないような内容です。複数の列を並べ替えるというような単純な内容の話ではありませんね。

本当は、そのデータの内容を見れたら分かったのでしょうけれども。

>列７（G列）には5種類の星マークを入力しています。まずこれを降順でソートして最上段に「★★★★★」が集まるようにします。

これは、分かりますが、コードと照らし合わせると、★の入っているのは、G列のみということですね。

>次にこの「★★★★★」の集まっている範囲内で　１，２，３などの数字が入っている列２（Ｂ列）を昇順でソートすると列７の「★★★★★」が上下に分散してしまいます。

こちらが書き換えると

まず、７列目（G列)で、星印「★～★★★★★」の行を集める
その範囲内で、他の行も、それに連動して集まる。

2～4は、昇順で、それ以外は、降順であるというのですと、よく分かりません。そのままですと、★自体も、★自体は分散しませんが、★の数に対しては分散します。

★の群の中で分散する形になると以下のサンプルのようになります。
ただし、最後に、もう一度、7列目(G列）を並べ替えれば、★は、正しく並べ替えられます。

なお、私の書くコードの場合は、Key1:=.Cells(2, i)　の2は、常に2です。意味は、ActiveSheet.Cells(8,i) ということになります。

また、
>データの上端は　A8～L8　にあります。
ということですが、コードをみるとO列まであるはずです。

Sub SortMacro2()
　　Dim r1 As Long
　　Dim r2 As Long
　　Dim i As Variant
　　Dim Incline As Integer

　　Incline = xlDescending '降順 , 'xlAscending　'昇順
　　r1 = ActiveSheet.Range("H65536").End(xlUp).Row

　　Application.ScreenUpdating = False
　　With ActiveSheet
　　　　With .Range(.Cells(7, 1), .Cells(r1, 15))
　　　　　　　　.Sort _
　　　　　　　　Key1:=.Cells(2, 7), _
　　　　　　　　Order1:=Incline, _
　　　　　　　　Header:=xlYes, _
　　　　　　　　OrderCustom:=1, _
　　　　　　　　MatchCase:=False, _
　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlPinYin
　　　　　For i = 2 To r1
　　　　　　If InStr(.Columns(7).Cells(i, 1).Value, "★") = 0 Then
　　　　　　　r2 = .Columns(7).Cells(i - 1, 1).Row
　　　　　　　Exit For
　　　　　　End If
　　　　　Next i

　　　　　End With

　　　　For Each i In Array(2, 3, 4, 6, 5, 1, 10, 8, 9, 11, 12, 13, 14, 15)
　　　　　　'With .Range(.Cells(7, i), .Cells(r2, i)) '１列独立型
　　　　　　With .Range(.Cells(7, 1), .Cells(r2, 15)) '左端上のセルを基点
　　　　　　　　If i = 2 Or i = 3 Or i = 4 Then
　　　　　　　　　　Incline = xlAscending
　　　　　　　　Else
　　　　　　　　　　Incline = xlDescending
　　　　　　　　End If
　　　　　　　　'もし１列独立型の場合は、.Cells(2,1), _ となる
　　　　　　　　If i > 15 Then MsgBox "間違ったデータが入っています。", 32: Exit Sub
　　　　　　　　.Sort _
　　　　　　　　Key1:=.Cells(2, i), _
　　　　　　　　Order1:=Incline, _
　　　　　　　　Header:=xlYes, _
　　　　　　　　OrderCustom:=1, _
　　　　　　　　MatchCase:=False, _
　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlPinYin
　　　　　　End With
　　　　Next i
　　End With
　　Application.ScreenUpdating = True

End Sub

p.s. 「別に、難しく考える必要がないと思いますが、違うのでしょうかしらね？」どうやら、難しく考えなくてはならないようですね（^^;

お礼

再度のご回答ありがとうございました。
試してみました。
最初の★★★★★は揃うのですが、次巡からうまくいきません。
A列B列が昇順になりません。
表現の仕方が下手でご迷惑をお掛けしました。
少し簡略化すると以下のような表です。
新規追加した場合も常に、個人評価＞a社＞b社＞c社の順に並べ替えたいのですが・・・。

A列　　B列　　 C列　　　　D列　　 　　　E列
a社　　 b社　 　c社　　　　個人評価　　　書名
１　　　２　　　　７　　　★★★★★　　「あ」
１　　　３　　　　６　　　★★★★★　　「い」
３　　　１　　　　６　　　★★★★★　　「か」
３　　　５　　　　３　　　★★★★★　　「え」
１　　　４　　　　５　　　★★★★　　　「さ」
２　　　４　　　　３　　　★★★★　　　「な」
２　　　３　　　　２　　　★★★　　　　「た」
２　　　６　　　　１　　　★★★　　　　「き」

しばらく締め切らずにおきたいと思いますので、差し支えなければお時間の取れましたときに再度アドバイスいただけると有難いと思います。
厚かましいお願いで申し訳ありません。

回答No.4

Wendy02

こんにちは。

別に、難しく考える必要がないと思いますが、違うのでしょうかしらね？
Array の中の列の順番を決めてください。今は、一番右から順に並べ替えするようにできています。（列は、列番号ではなく、あくまでも順番です）

ただし、その表は、基点なる部分が、A7 にあるような気がしますが、その場合は、以下のコードの　A1 を書き換えてください。また、それぞれの昇順・降順が変わるようなら、別途オプションをつけなくてはなりません。

Sub SortMacro()
　　Dim i As Variant
　　Dim Incline As Integer
　　Incline = xlDescending '降順 , 'xlAscending　'昇順

　　Application.ScreenUpdating = False
　　With ActiveSheet.Range("A1").CurrentRegion '左端上のセルを基点
　　　　For Each i In Array(10, 9, 8, 7, 6, 5, 4, 3, 2, 1)
　　　　　　If i > .Columns.Count Then MsgBox "間違ったデータが入っています。", 32: Exit Sub
　　　　　　　　.Sort _
　　　　　　　　Key1:=.Cells(2, i), _
　　　　　　　　Order1:=Incline, _
　　　　　　　　Header:=xlYes, _
　　　　　　　　OrderCustom:=1, _
　　　　　　　　MatchCase:=False, _
　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlPinYin
　　　　　　Next i
　　　　End With
　　　　Application.ScreenUpdating = True
End Sub

お礼

ご回答ありがとうございました。
ご推察通りタイトル行は７で、データの上端は　A8～L8　にあります。
現在は200行ほどですが暫時増えます。
各行のデータは同一のものも複数含まれています。
たとえば「１」や「２００６」「★★★★★」「★★」など。
空白欄もありますが　H列　には必ずデータが入力されます。
それで、並べ替えの範囲を確実に選択するために、
ActiveSheet.Range("H65536").Select
Selection.End(xlUp).Select
r1 = ActiveCell.Row
としてデータ最終行番号の値を特定しています。
教えていただいた式を組み合わせて補足欄のようにしてみましたが、うまくいきません。

列７（G列）には5種類の星マークを入力しています。
まずこれを降順でソートして最上段に「★★★★★」が集まるようにします。
（ここは一巡目でうまういきます）
次にこの「★★★★★」の集まっている範囲内で　１，２，３などの数字が入っている列２（Ｂ列）を昇順でソートすると列７の「★★★★★」が上下に分散してしまいます。
（列２だけを優先して並び替えてしまう）
一回ソート済みの列の並びは動かないようにしたいのですが、式の添削をお願いできないでしょうか。
分割する方法もとれそうですが、一連の式で記述する方法があれば覚えたいと思いますのでもう少し教えていただくと有難いと思います。
説明の仕方が悪くて意図を正確にお伝えできなかったかもしれませんが、またお忙しいところ恐れ入りますがよろしくお願いいたします。

補足

Dim r1
Dim i As Variant
Dim Incline As Integer
Incline = xlDescending '降順 , 'xlAscending　'昇順
ActiveSheet.Range("H65536").Select
Selection.End(xlUp).Select
r1 = ActiveCell.Row

Application.ScreenUpdating = False
With ActiveSheet.Range(Cells(8, 1), Cells(r1, 15)) '左端上のセルを基点
For Each i In Array(7, 2, 3, 4, 6, 5, 1, 10, 8, 9,11,12,13,14,15)

If i = 2 Or i = 3 Or i = 4 Then
Incline = xlAscending
Else
Incline = xlDescending
End If

If i > .Columns.Count Then MsgBox "間違ったデータが入っています。", 32: Exit Sub
.Sort _
Key1:=.Cells(8, i), _
Order1:=Incline, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
Next i
End With
Application.ScreenUpdating = True

End Sub

回答No.3

imogasi

ソートについては
その内部的に使われている、ソートのプログラム方式によって
別のソートキーで並べ変えたとき
直前の並び順について、ソートした部分のキー（エクセルでは普通は列）に付いて
（１）前の並び順が保存されるもの（安定ソート、下記WEB記事参照）
（２）前の並び順が崩れてしまうもの
があります。
エクセルは幸い（１）なので、下位のキー（エクセルでは普通は列）から順次最大３つ以内づつソートを行えば、質問の課題達成は可能です。
安定性について
http://bakera.jp/ebi/topic/760
http://www-wada.elcom.nitech.ac.jp/~wada/DA/2/DA-lec/7th.pdf
http://tcslab.csce.kyushu-u.ac.jp/~sada/lectures/exercise9ans.pdf
その他「ソート　アルゴリズム　安定性」で照会すると多数出る。

お礼

ご回答ありがとうございました。
エクセルは安定ソートと教えていただき大変心強く思います。
とても参考になりました。

回答No.2

mshr1962

エクセルでは、下のほうの項目から順に並べ替えするしかありません
処理を4つに分けます。
処理1　条件10 で並べ替え
処理2　条件7,条件8,条件9で並べ替え
処理3　条件4,条件5,条件6で並べ替え
処理4　条件1,条件2,条件3で並べ替え
これをマクロで記録すれば可能ですが．．．

お礼

ご回答ありがとうございました。
あ、なるほど。
そういう手がありましたか。

エクセルの問題というより機転に近いものでしょうか^^;
早速試してみます。
大変参考になりました。

回答No.1

hana-hana3

設定出来るのは３つまでなので、一度に１０項目は不可能です。

お礼

やはりそうですか。
何かいい方法はないものかと思ったのですが残念です。
ご回答ありがとうございました。