【Excel VBA】複数範囲の並べ替えは可能でしょうか？

Question

【Excel VBA】複数範囲の並べ替えは可能でしょうか？

Excel2003を使用しています。
CSVデータを元に作成された下記のような表があります。
A列…日付、B列…受注番号、C列…摘要(会社名・品名等)、D列…金額となっています。
6行目以下に上記の内容でデータが入力されていますが、会社ごとのデータ内で日付順に並べ替えをしたいのですが、VBAで複数の範囲を選択して、それぞれの範囲内での並べ替えは可能でしょうか？

　　　　A　　　　　B　　　　　C　　　　D
6　　　　　　　　　　　　　○○会社
7　　　1/20　　　123　　　AAA　　　1,000
8　　　1/15　　　120　　　BBB　　　2,000
9
10　　　　　　　　　　　　　　計　　　　 3,000
11
12　　　　　　　　　　　　××会社
13

計の1行上と下は空欄行で、以下、会社名の後にデータが続くというパターンの繰り返しで数十社分あります。
Excelのデータ⇒並べ替えでは複数選択した状態での並べ替えはできないので、VBAで可能であればと思い、質問させていただきました。
よろしくお願いします。

Wendy02 · Accepted Answer

こんにちは。

すでに完成形のコードは出ていますが、私ならこう作るというものを考えてみました。
というか、単にコード・スタイルにこだわっているだけですが……。

'-------------------------------------------

Sub DateSortMacro1()
　　Dim r As Range
　　Dim d As Variant
　　On Error Resume Next
　　With Columns("A").SpecialCells(xlCellTypeConstants, 1)
　　If Err.Number > 0 Or IsDate(.Cells(1, 1).Text) = False Then _
　　　　MsgBox "適当なシートでないか、A列にシリアル値の日付のデータがありません。", vbExclamation: Exit Sub
　　　　On Error GoTo 0
　　　　Application.ScreenUpdating = False
　　　　For Each r In .Areas
　　　　　　Call sSortPro(r.Resize(, 4))
　　　　Next r
　　Application.ScreenUpdating = True
　　End With
End Sub
Private Sub sSortPro(rng As Range)
　　Const i As Integer = 2 '計を入れる場所
　　rng.Sort Key1:=rng.Cells(1), _
　　Order1:=xlAscending, _
　　Header:=xlNo, _
　　Orientation:=xlTopToBottom
　　''計を再計算させるオプション
'　　If i <= 0 Then Exit Sub
'　　rng.Cells(rng.Cells.Count).Offset(i, -1).Value = "計"
'　　rng.Cells(rng.Cells.Count).Offset(i).FormulaLocal _
　　= "= SUM(" & rng.Columns(4).Address(0, 0) & ")"
End Sub

noname#130090 · Answer

では、僕も直して公開します。僕はC列に社名が入っていると何故か勘違いをしたため C列を昇順にした後A列を昇順にしていたせいでおかしなものになっていました。 Public Sub sort_asc() 　　Dim i As Long 　　For i = 1 To Range("A65536").End(xlUp).Row 　　　　If Range("A" & i) <> "" And Range("A" & i + 1) <> "" Then 　　　　　　Range(Range("A" & i), Range("A" & i).End(xlDown). _ 　　　　　　　　　　End(xlToRight)).Sort Key1:=Range("A" & i) 　　　　　　i = Range("A" & i).End(xlDown).Row 　　　　End If 　　Next i End Sub これでいけると思います。

merlionXX · Answer

> 下記のようにデータが1行しかない場合に、そのようになってしまっているようです。

No2　merlionXXです。
並べ替えなので1行のみのデータとは想定外でした。
Wendy02さまにはとても及びませんが、一応1行でもOKなように修正してみました。

Sub test02()
　　Set myRng = Range("A7")
　　Do While IsDate(myRng)
　　　　If myRng.Offset(1) <> "" Then
　　　　　　Range(Range(myRng, myRng.End(xlDown)), Range(myRng, myRng.End(xlDown)).End(xlToRight)).Select
　　　　　　Selection.Sort Key1:=Selection(1), Order1:=xlAscending, Header:=xlNo
　　　　　　Set myRng = Selection(1).End(xlDown).End(xlDown)
　　　　Else
　　　　　　Set myRng = myRng.End(xlDown)
　　　　End If
　　Loop
　　Set myRng = Nothing
End Sub

merlionXX · Answer

Sub test01()
　　Set myRng = Range("A7")
　　Do While IsDate(myRng)
　　　　Range(Range(myRng, myRng.End(xlDown)), Range(myRng, myRng.End(xlDown)).End(xlToRight)).Select
　　　　Selection.Sort Key1:=Selection(1), Order1:=xlAscending, Header:=xlNo
　　　　Set myRng = Selection(1).End(xlDown).End(xlDown)
　　Loop
　　Set myRng = Nothing
End Sub

ではいかがでしょう？

noname#130090 · Answer

これで上手くいきますかねえ？
いきなり本番でやるのは怖いので
一度別で保存してからやってみてください。

Public Sub sort_asc()
　　Dim i As Long
　　For i = 0 To Range("A65536").End(xlUp).Row - 1
　　　　If Range("A1").Offset(i) <> "" Then
　　　　　　Range("A1").Offset(i).CurrentRegion.Select
　　　　　　Selection.Sort Key1:=Range("C1").Offset(i), _
　　　　　　Key2:=Range("A1").Offset(i)
　　　　　　i = Range("A1").Offset(i).End(xlDown).Row
　　　　End If
　　Next i
End Sub

【Excel VBA】複数範囲の並べ替えは可能でしょうか？

こんにちは。

では、僕も直して公開します。

> 下記のようにデータが1行しかない場合に、そのようになってしまっているようです。

Sub test01()

これで上手くいきますかねえ？

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング