[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数の並び替えをマクロで行いたい』（かよこ）
A列にある同じ数字のみB列C列を並び替えしたいです。
A列に数字があり同じ数字が3行から10行つづいています。 そのA列で同じ数字のみの並び替えをしたいです。
例えば A B C 1 101 1 2 2 101 100 12 3 101 10 11 4 102 100 1 5 102 10 5 6 102 1 2 7 102 1000 8 8 103 10 7 9 103 1 9 10 103 100 8
これをA列が同じA1からC3、A4からC7、A8からC10 それぞれをB列の大きい順に並び替えたいです。
A B C 1 101 100 12 2 101 10 11 3 101 1 2 4 102 1000 8 5 102 100 1 6 102 10 5 7 102 1 2 8 103 100 8 9 103 10 7 10 103 1 9
このようにしたいです。 だいたい1000行から2000行とあるのでボタン1つでできればと思います。 わかりづらくてすいませんが、よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
おはようございます。。。でもないかな？(^^; 取り敢えず、多段配列にそれぞれ取り込んでクイックソートで並び替えてみてはどうでしょうか？
あぁぁぁ、思いっきり間違えました。 B列を基準に並び替えるんですね？？ D列E列？？？ この後に貼り付ければいいのかな？？？ ちょっとバタバタしてますので後で時間があれば考えます。。。 取り敢えず、、、
A列の並びは変えないで違うKeyが来たら並び替える。。。を繰り返してみました。 でも最初からE列とかD列の情報を教えてくれないと二度手間になっちゃいますので。。。 では、、では、、
101 1 2 あ1 え1 101 100 12 あ2 え2 101 10 11 あ3 え3 102 100 1 あ4 え4 102 10 5 あ5 え5 102 1 2 あ6 え6 102 1000 8 あ7 え7 103 10 7 あ8 え8 103 1 9 あ9 え9 103 100 8 あ10 え10
101 100 12 あ1 え1 101 10 11 あ2 え2 101 1 2 あ3 え3 102 1000 8 あ4 え4 102 100 1 あ5 え5 102 10 5 あ6 え6 102 1 2 あ7 え7 103 100 8 あ8 え8 103 10 7 あ9 え9 103 1 9 あ10 え10
Option Explicit
Sub てすと()
Dim y As Variant
Dim v As Variant
Dim q As Variant
Dim r As Variant
Dim MyKey As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim Myflg As Boolean
v = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 3).Value
ReDim q(LBound(v, 1) To UBound(v, 1), 1 To 2)
For i = LBound(v, 1) To UBound(v, 1)
If MyKey <> v(i, 1) Then
MyKey = v(i, 1)
If Myflg = False Then
ReDim y(0)
Myflg = True
Else
ReDim Preserve y(UBound(y) + 1)
End If
ReDim r(1 To 2, 1 To 1)
r(1, 1) = v(i, 2)
r(2, 1) = v(i, 3)
y(UBound(y)) = r
Else
r = y(UBound(y))
ReDim Preserve r(1 To 2, 1 To UBound(r, 2) + 1)
r(1, UBound(r, 2)) = v(i, 2)
r(2, UBound(r, 2)) = v(i, 3)
y(UBound(y)) = r
End If
Next
For i = LBound(y) To UBound(y)
r = Application.Transpose(y(i))
QuickSort r, 1, LBound(r, 1), UBound(r, 1)
For j = LBound(r, 1) To UBound(r, 1)
k = k + 1
q(k, 1) = r(j, 1)
q(k, 2) = r(j, 2)
Next
Next
With Sheets("Sheet1")
With .Range("B1").Resize(UBound(q, 1), UBound(q, 2))
.ClearContents
.Value = q
End With
End With
Erase y, v, q, r
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) > MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) < MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
（SoulMan） 2021/05/09(日) 11:26
ありがとうございます。
これだとA列からC列はできるのですが、D列E列が消えてしまいます。
D列E列はそのまま残しておきたいです。
よろしくお願いいたします。 （かよこ） 2021/05/09(日) 11:43
A列は既に昇順で並んでいるように見えますが、
第1キーをA列で昇順、第1キーをB列で降順 で並べ替えるのとはちがうのでしょうか？ （´・ω・`） 2021/05/09(日) 11:44
ほんとですね(^^; そのまんまじゃないですかぁ？？？ 全部、、それぞれ並び替えるのかと勘違いしました。m(__)m よく見ないで書き出しちゃったので、、、あぁあっぁって感じです。。。 （SoulMan） 2021/05/09(日) 12:29
Sub test()
Range("A1:C10").Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlDescending, _
Header:=xlNo
End Sub
こんな感じでしょうね。
【補足】 ・Excel2003までは、RangeオブジェクトにSortメソッドがあり、 これを使っていました。 同時に指定できるキーの数が3つまでとなっていました。 ・Excel2007では、キー数の上限等について機能拡張され、 同時に、SortオブジェクトやSortFieldオブジェクト等が作られました。
http://officetanaka.net/excel/vba/tips/tips148.htm
を参照下さい。
・マクロ記録をとると、後者の方式のものが記録されますが、 このケースのように簡単なソートであれば、Sortメソッドを使った前者のほうが 簡単に書けます。（依然としてSortメソッドは使えます。）
対象範囲を可変にして、
Sub test()
Range("A1").CurrentRegion.Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlDescending, _
Header:=xlNo
End Sub
としたものを、ボタンに登録しておけば、良いでしょう。
# ちょっと書き出していたので、茶々入れ失礼しました。 （γ） 2021/05/09(日) 13:19
お返事ありがとうございます。
>Sub test()
> Range("A1:C10").Sort _
> Key1:=Range("A1"), Order1:=xlAscending, _
> Key2:=Range("B1"), Order2:=xlDescending, _
> Header:=xlNo
> End Sub
これですと、A列の順番も変わってしまいます。 あくまでもB列、C列のみを並び替えしたいです。 A列はそのままでお願いします。
よろしくお願いいたします。 （かよこ） 2021/05/09(日) 14:04
（γ） 2021/05/09(日) 14:29
すいません。
例ではわかりやすくA列は順番にしましたが実際は違います。
A列は毎回順番がかわります。
またA列とD列E列も他の計算で関係を持っていますので 同じA列に対して単純にB列C列のみの並び替えをしたいです。
自分でわかれば手直ししますが、うまくいきませんでした。
よろしくお願いいたします。 （かよこ） 2021/05/09(日) 14:45
上のコードを直しておきましたので試してみてください。 （SoulMan） 2021/05/09(日) 14:54
これはSheet1からSheet2になっていますが、同じシートですと難しいのでしょうか？
またD列とE列はA列からC列のみ並べ替えるのでそのまま使えると
思っていました。
すいません。
よろしくお願いいたします。
（かよこ） 2021/05/09(日) 15:49
簡単です。(^^; ただ、、お馬ちゃんしながら書いてますのでミスが多いだけです。(^^; 直したつもりです。。お試しください。。。 では、、では、、 （SoulMan） 2021/05/09(日) 16:01
みなさん大変お世話になりました。
無事にできました。
ありがとうございました。 （かよこ） 2021/05/09(日) 16:18
# 散歩から戻りました。
解決されたようですが、別の方法を提示しておきます。
・作業列をA列に作り、元のA列のグループ毎に連番を付与したうえで、 ・第1優先キーはその連番、第2優先キーは元のB列に指定して ソートすればよいのではないですか？
Sub test()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'作業列をA列に挿入し、グループ毎の連番を付与
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = 1
With Range("A2").Resize(lastRow - 1, 1)
.Formula = "=IF(B2=B1,A1,A1+1)"
.Value = .Value
End With
'ソート（第1キー：連番,第2キー:元のB列)
Range("A1").CurrentRegion.Resize(,4).Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("C1"), Order2:=xlDescending, _
Header:=xlNo
'作業列を削除
Columns("A").Delete
End Sub
# 3列のみソート対象とのこと。反映済み。(5/10)
# ご自分で理解するよう努められんことを願う。
（γ） 2021/05/09(日) 18:11
今回の件の場合、
1）C列のどこかのデータを選択 → 降順で並び替え
2）B列のどこかのデータを選択 → 降順で並び替え
3）A列のどこかのデータを選択 → 昇順で並び替え
という手順で、できるように思えます。
コツとしては優先度の低い列から順番に並び替えるとよいです。
マクロ化したければその手順をマクロの記録機能でマクロのコードに翻訳してもらいます。
結果が以下
Option Explicit
Sub Macro1() ' ' Macro1 Macro '
'
Range("C3").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("C3:C10") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:C10")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B2").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("B2:B10") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:C10")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A3").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A3:A10") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:C10")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=0
End Sub
なーんかすごいややこしくなりました。
「Sortメソッド」という言葉が他の回答にあります。
それをキーワードにしてWebで検索してみて、使い方を勉強してみてください。
ソートメソッドを使った例
Sub test2()
With ActiveSheet.UsedRange
.Sort .Cells(3), xlDescending
.Sort .Cells(2), xlDescending
.Sort .Cells(1), xlAscending
End With
End Sub
マクロの前にエクセルの使い方も覚えましょう。
詳しい説明は省きます。わからない点を聞いてください。
（まっつわん） 2021/05/10(月) 12:39
（γ） 2021/05/10(月) 14:28
一時的に小計機能でキーブレークの箇所に行を挿入して、
分けられたグループごとに並び替えを繰り返すと、よいかとは思いますが。
（まっつわん） 2021/05/10(月) 15:13
（γ） 2021/05/10(月) 15:34
γさんがいいコード上げてたので、書き込まなかったですが、
愚直にやるならコンナ風になるんですけども
Sub sample()
Dim aCell As Range, n As Long
Set aCell = Range("A1")
Do While aCell.Value <> ""
n = WorksheetFunction.CountIf(Columns(1), "=" & aCell.Text)
With aCell.Offset(, 1).Resize(n, 2)
.Sort Key1:=aCell.Offset(, 1), Order1:=xlDescending
Set aCell = aCell.Offset(n)
End With
Loop
End Sub
A列のユニークな数によりますけど、 小さなブロックでのソートを繰り返してたら、速くはないだろうな、という．．． （´・ω・`） 2021/05/10(月) 15:49
こんばんは！ 盛り上がってますねぇ(^^; 学校らしくていいことです。。。 ということで、、私も別回答をお一つ。。。 なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。 では、、では、、
Option Explicit
Sub てすと()
Dim MyScs As Object
Dim v As Variant
Dim q As Variant
Dim MyKey As Variant
Dim i As Long
Dim j As Long
Dim k As Long
v = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 3).Value
ReDim q(LBound(v, 1) To UBound(v, 1), 1 To 2)
Set MyScs = CreateObject("System.Collections.SortedList")
MyKey = v(1, 1)
For i = LBound(v, 1) To UBound(v, 1)
If MyKey <> v(i, 1) Then
For j = MyScs.Count - 1 To 0 Step -1
k = k + 1
q(k, 1) = MyScs.GetKey(j)
q(k, 2) = MyScs.Getbyindex(j)
Next
MyKey = v(i, 1)
Set MyScs = CreateObject("System.Collections.SortedList")
MyScs.Add v(i, 2), v(i, 3)
Else
MyScs.Add v(i, 2), v(i, 3)
End If
Next
For j = MyScs.Count - 1 To 0 Step -1
k = k + 1
q(k, 1) = MyScs.GetKey(j)
q(k, 2) = MyScs.Getbyindex(j)
Next
With Sheets("Sheet1")
With .Range("B1").Resize(UBound(q, 1), UBound(q, 2))
.ClearContents
.Value = q
End With
End With
Set MyScs = Nothing
Erase v, q
End Sub
（SoulMan） 2021/05/10(月) 21:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.