こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

投稿日時 - 2010-02-01 16:52:40

QNo.5640919

困ってます

質問者が選んだベストアンサー

こんにちは。

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

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

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

投稿日時 - 2010-02-02 11:33:56

お礼

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

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

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

投稿日時 - 2010-02-02 14:36:56

ANo.3

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(5)

では、僕も直して公開します。
僕は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


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

投稿日時 - 2010-02-03 19:35:34

お礼

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

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

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

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

投稿日時 - 2010-02-04 09:17:50

ANo.4

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

投稿日時 - 2010-02-02 17:59:14

お礼

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

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

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

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

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

投稿日時 - 2010-02-03 11:31:44

ANo.2

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

ではいかがでしょう?

投稿日時 - 2010-02-02 09:44:00

お礼

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

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


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

        計      1,000


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

投稿日時 - 2010-02-02 14:26:32

これで上手くいきますかねえ?
いきなり本番でやるのは怖いので
一度別で保存してからやってみてください。

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

投稿日時 - 2010-02-02 09:25:58

お礼

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

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

コード内の
>Selection.Sort Key1:=Range("C1").Offset(i)

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

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

投稿日時 - 2010-02-02 14:15:48

あなたにオススメの質問