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

【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で可能であればと思い、質問させていただきました。
よろしくお願いします。

No.3 ベストアンサー 回答者： Wendy02 回答日時： 2010/02/02 11:33

こんにちは。

すでに完成形のコードは出ていますが、私ならこう作るというものを考えてみました。
というか、単にコード・スタイルにこだわっているだけですが……。

'-------------------------------------------

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

この回答へのお礼

回答ありがとうございます。

教えていただいたコードで試してみたところ、希望通りの結果を得ることができました。
マクロが終了するまであっという間だったので、今まで手作業で1社ずつ範囲選択⇒並べ替えをしていたのがちょっと悲しくなりました。

計を再計算させるオプションまで…すごいです！！
今回はCSVデータをそのまま使用しているので、計算式は入力されていないのですが、勉強になりました。
ありがとうございました。

お礼日時：2010/02/02 14:36

No.5 回答者： noname#130090 回答日時： 2010/02/03 19:35

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

僕は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


これでいけると思います。

この回答へのお礼

再度の回答ありがとうございます。

＞僕はC列に社名が入っていると何故か勘違いをしたため

勘違いをされていたのではなく、C列には社名が入力されている行もあります。
質問文で挙げた例がわかりづらかったようで、お手数をおかけしてしまい申し訳ありません。
修正してくださったコードで試してみたところ、希望通りの結果を得られました。

今回は、それぞれ違った方法での回答をいただき、大変勉強になりました。
ありがとうございました！

お礼日時：2010/02/04 09:17

No.4 回答者： merlionXX 回答日時： 2010/02/02 17:59

> 下記のようにデータが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

この回答へのお礼

再度の回答ありがとうございます。

＞並べ替えなので1行のみのデータとは想定外でした。

そうですよね。最初からもう少し例を挙げておくべきでした。
お手数をおかけしてしまい、申し訳ありません。
修正してくださったコードで希望通り動作しました。

＞Wendy02さまにはとても及びませんが、一応1行でもOKなように修正してみました。

私にとってはいろんな方法を目にすることが出来るので、勉強になりますし助かります。
ありがとうございました！

お礼日時：2010/02/03 11:31

No.2 回答者： merlionXX 回答日時： 2010/02/02 09:44

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

ではいかがでしょう？

この回答へのお礼

回答ありがとうございます。

教えていただいたコードで試してみたところ、別会社の中にデータが入り込んでしまっている場合が一部ありました。
下記のようにデータが1行しかない場合に、そのようになってしまっているようです。


　　　　　　　　○○会社
2/1　　123　　　AAA　　　1,000

　　　　　　　　計　　　　　　1,000


1社のデータが2行以上の場合は希望通りの結果が得られていましたので、少し手を加えてみたいと思います。
ありがとうございました。

お礼日時：2010/02/02 14:26

No.1 回答者： noname#130090 回答日時： 2010/02/02 09:25

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

いきなり本番でやるのは怖いので
一度別で保存してからやってみてください。

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

この回答へのお礼

回答ありがとうございます。

教えていただいたコードで試してみたところ、マクロは実行されているようですが、A列の日付順での並べ替えはできていませんでした。

コード内の
＞Selection.Sort Key1:=Range("C1").Offset(i)
を
Selection.Sort Key1:=Range("A1").Offset(i)
に書き換えて再度試してみたところ、日付順での並べ替えはできたのですが、C列の会社名が最後の行になってしまいました。
日付(A列)が空欄だからそのようになってしまうのでしょうが、何か条件を加えるとうまくいくかもしれませんね。もう少し考えてみようと思います。

ありがとうございました。

お礼日時：2010/02/02 14:15