Excel2003 並び替えに関する質問 VBA初心者

質問

エクセルの並び替えにおいて質問させていただきます。

　A列　　B列　　C列　　 D列
りんご　　1　　バナナ　　4
バナナ　　2　　みかん　　6
すいか　　3　　いちご　　8
みかん　　4　　もも　　　3
いちご　　5　　すいか　　2
ドリア　　6　　ぶどう　　1

というものを

　A列　　B列　　C列　　 D列
りんご　　1　　
バナナ　　2　　バナナ　　4
すいか　　3　　すいか　　2
みかん　　4　　みかん　　6
いちご　　5　　いちご　　8
ドリア　　6　　
　　　　　　　 もも　　　3
　　　　　　　 ぶどう　　1

というようにA列にならってC,D列の項目を並び替えて、並び替えられないものは下に列挙させるようなやり方をVBAで組みたいのですが、まずはどうすればよいのかわかりません。

もし、これを見て答えられるようであれば、どなたか教えていただければ幸いです。

どうか宜しくお願いします。

回答No.3

Wendy02

#1 の回答者です。
コードと説明の文書が入れ違っています。
コードの中が、データの最初が、2行目に書かれています。

A2, C2 になっている部分を、A1,C1 に書き換えてください。

Set r1 = .Range("A1", .Range("A65536").End(xlUp))
Set r2 = .Range("C1", .Range("C65536").End(xlUp))

回答No.2

Bickyon

考え方としてラフに書くと、以下のような感じでしょうか。

1.C列1行目内容がA列1行目からA列の空白以外の行までに存在するか
　この時に、A列が何行目まであるか調べておく
2.n行目に存在したとき
　C、D列1行目内容をE、F列n行目にコピー
3.存在しなかったとき
　存在しなかったのは何個目かカウントする。
　C、D列1行目内容をE、F列のA列最終行+何個目行目にコピー
4.C列次行について、空白になるまで1.から繰り返す。
5.C、D列を削除する。

Dim Cnt1 As Integer
Dim Cnt2 As Integer
Dim Cnt3 As Integer
Dim Flg As Integer

Range("C1").Select
Cnt1 = 0
Cnt3 = 0

Do Until ActiveCell.Offset(Cnt1, 0).Value = "" 'C列が空になるまで繰り返す
Cnt2 = 0
Flg = 0
Do Until ActiveCell.Offset(Cnt2, -2).Value = "" 'A列が空になるまで繰り返す

If ActiveCell.Offset(Cnt1, 0).Value = ActiveCell.Offset(Cnt2, -2).Value Then
ActiveCell.Offset(Cnt2, 2).Value = ActiveCell.Offset(Cnt1, 0).Value
ActiveCell.Offset(Cnt2, 3).Value = ActiveCell.Offset(Cnt1, 1).Value
Flg = 1
Exit Do
End If

Cnt2 = Cnt2 + 1
Loop

If Flg = 0 Then
ActiveCell.Offset(Cnt2 + Cnt3, 2).Value = ActiveCell.Offset(Cnt1, 0).Value
ActiveCell.Offset(Cnt2 + Cnt3, 3).Value = ActiveCell.Offset(Cnt1, 1).Value
Cnt3 = Cnt3 + 1
End If
Cnt1 = Cnt1 + 1

Loop

Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Range("C1").Select

回答No.1

Wendy02

こんばんは。

>これを見て答えられるようであれば、

ご希望にかなって、答えられているのかは分かりませんが、こんな風にしたらどうでしょうね。でも、私のコードでは勉強にはならないかもしれませんね。

>並び替えられないものは下に列挙させるようなやり方をVBAで組みたいのですが、

以下の私のコードは、見た目は簡単ですが、Range型で範囲を捉えても、同じ場所で、上書きするようなコードは、初級では出来ません。同じ場所の場合は、一旦、配列などに確保しないと並べ替えは出来ないのです。

場所は、A列、C列の１行目からになっています。
もし、違う場合は、以下を調節してください。

Set r1 = .Range("A1",.Range("A65536").End(xlUp))
Set r2 = .Range("C1", .Range("C65536").End(xlUp))

後は、変える必要はありません。
一度、並べ替えたものは、もう一度やっても、並べ替えはしていても、見かけは変化しません。なお、文字の空白値が入っていることがありますから、その場合は、必ず、空白値は除去しないと、うまく並べ替えられません。

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

Sub Test1()
　　Dim i As Variant
　　Dim j As Long
　　Dim k As Long
　　Dim n As Long
　　Dim r1 As Range
　　Dim r2 As Range
　　Dim Ary1 As Variant
　　Dim Ary2 As Variant
　　Dim c As Variant
　　With ActiveSheet
　　Set r1 = .Range("A2", .Range("A65536").End(xlUp))
　　Set r2 = .Range("C2", .Range("C65536").End(xlUp))
　　End With
　　n = Application.CountA(r1)

　　ReDim Ary1(r1.Rows.Count - 1, 1)
　　ReDim Ary2(r2.Rows.Count - 1, 1)

　　For Each c In r2
　　　　i = Application.Match(c.Value, r1, 0)
　　　　If c.Value <> "" Then
　　　　　　If IsError(i) Then
　　　　　　　　'A列にない
　　　　　　　　Ary2(k, 0) = c.Value
　　　　　　　　Ary2(k, 1) = c.Offset(, 1).Value
　　　　　　　　k = k + 1
　　　　　　Else
　　　　　　　　'A列にある
　　　　　　　　Ary1(i - 1, 0) = c.Value
　　　　　　　　Ary1(i - 1, 1) = c.Offset(, 1).Value
　　　　　　End If
　　　　End If
　　Next c
　　r2.Cells(1, 1).Resize(n, 2).Value = Ary1
　　r2.Cells(1, 1).Offset(n).Resize(k, 2).Value = Ary2
　　Set r1 = Nothing
　　Set r2 = Nothing
End Sub