ＶＢＡでグループごとソートする方法がわかりません。

質問

下記のようなソートをVBAで行いたいのですがわかりません。
３行２列ずつ入れ替え、その結果を別シートに作成したいのです。

A 　　　B 　　　C 　　　D 　　　E 　　　F 　　　G 　　　H 　　　I 　　　J 　　　K 　　　L
5 　　　佐藤　　6 　　　鈴木　3 　　　高橋　　8 　　　磐田　5 　　中根　　5 　　　後藤
da8 　　　　　　da4 　　　　　　da6 　　　　　　da1 　　　　　　da1 　　　　　da5

　↓（２行目の数を基準に３行２列ごと入れ替え）

E 　　　F 　　　A 　　　B 　　　I 　　　J 　　　K 　　　L 　　　C 　　　D 　　　G 　　　H
3 　　　高橋　　5 　　　佐藤　5 　　中根　　5 　　 後藤　 6 　　 鈴木　　8 　　　磐田
da6 　　　　　　da8 　　　　　　da1 　　　　　da5 　　　　　　 da4 　　　　　da1

　↓（最初の条件を満たしたまま、３行目のdaに続く数を基準に３行２列ごと入れ替え）

E 　　　F 　　　I 　　　J 　　　K 　　　L 　　　A 　　　B 　　　C 　　　D 　　　G 　　　H
3 　　　高橋　　5 　　　中根　5 　　後藤　　5 　　 佐藤　 6 　　 鈴木　　8 　　　磐田
da6 　　　　　　da1 　　　　　　da5 　　　　　da8 　　　　　　 da4 　　　　　da1

最近VBAを勉強し始め、「かんたんプログラミング　EXCEL　VBA」という書籍を読んだ知識レベルのため、なかなか苦戦しております。お時間ありましたら、考え方のヒントもしくは教えていただけないでしょうか？
以下を貼り付けてカット＆ペーストしていただいたらデータを作成しやすいです。
ABCDEFGHIJKL
5佐藤6鈴木3高橋8磐田5中根5後藤
da8da4da6da1da1da5

回答No.4

Wendy02 · ベストアンサー

こんばんは。

読みきりました。これは、基本的な表の作り方が間違ってしまっているから、これは、マクロ以前の問題だと思います。別に表がきちんと作れていれば、マクロは必要ないと思います。以下は、途中で、並べ替えのできる表が出てきますので、途中で止めてみてもよいと思います。

Sub TestSort()
　　Dim r As Range
　　Dim ar1 As Variant
　　Dim ar2 As Variant
　　Dim ar3 As Variant
　　Dim ar4 As Variant
　　Dim i As Integer
　　Dim j As Integer
　　Dim k As Integer
　　Dim CopyCell As Range 'コピー先

　　Set r = Range("A1").CurrentRegion
　　If r.Rows.Count > 3 Then MsgBox "今回のマクロでは完了できません": Exit Sub

　　'配列のIndexの上限
　　k = Int(r.Columns.Count / 2) - 1

　　ReDim ar1(0 To k)
　　ReDim ar2(0 To k)
　　ReDim ar3(0 To k)
　　ReDim ar4(0 To k)

　　Set CopyCell = r.Cells(6, 1) 'コピー先 A6 から

　　'データ取得
　　For i = 1 To r.Columns.Count Step 2
　　　　ar1(j) = r.Cells(1, i).Value & "," & r.Cells(1, i + 1).Value
　　　　j = j + 1
　　Next i
　　j = 0
　　For i = 1 To r.Columns.Count Step 2
　　　　ar2(j) = r.Cells(2, i).Value
　　　　j = j + 1
　　Next i
　　j = 0
　　For i = 1 To r.Columns.Count Step 2
　　　　ar3(j) = r.Cells(3, i).Value
　　　　j = j + 1
　　Next i
　　j = 0
　　For i = 1 To r.Columns.Count Step 2
　　　　ar4(j) = r.Cells(2, i + 1).Value
　　　　j = j + 1
　　Next i

　　'作業セル空間にコピー
　　With Range("A100").Resize(, k + 1)
　　　　.Value = ar1
　　　　.Offset(1).Value = ar2
　　　　.Offset(2).Value = ar3
　　　　.Offset(3).Value = ar4
　　End With

　　'並べ替え
　　Range("A100").CurrentRegion.Sort _
　　Key1:=Range("A101"), Order1:=xlAscending, _
　　Key2:=Range("A102"), Order2:=xlAscending, _
　　Header:=xlGuess, _
　　OrderCustom:=1, _
　　MatchCase:=False, _
　　Orientation:=xlLeftToRight

　　Set r2 = Range("A100").CurrentRegion '作業セル空間の確保
　　j = 1
　　'CopyCellを中心にしてコピーする
　　For i = 1 To r2.Columns.Count
　　　　CopyCell.Cells(1, j).Value = Split(r2.Cells(1, i).Value, ",")(0)
　　　　CopyCell.Cells(1, j + 1).Value = Split(r2.Cells(1, i).Value, ",")(1)
　　　　j = j + 2
　　Next i
　　For i = 1 To r2.Columns.Count
　　　　CopyCell.Cells(2, (i - 1) * 2 + 1).Value = r2.Cells(2, (i - 1) + 1).Value
　　Next i
　　For i = 1 To r2.Columns.Count
　　　　CopyCell.Cells(3, (i - 1) * 2 + 1).Value = r2.Cells(3, (i - 1) + 1).Value
　　Next i
　　For i = 1 To r2.Columns.Count
　　　　CopyCell.Cells(2, i * 2).Value = r2.Cells(4, (i - 1) + 1).Value
　　Next i

　　'作業空間の削除
　　Range("A100").CurrentRegion.ClearComments
　　Set CopyCell = Nothing: Set r = Nothing: Set r2 = Nothing

End Sub

回答No.3

Dxak

Excelのソートを使用しない場合で・・・
> 考え方のヒントもしくは教えていただけないでしょうか？
で、自分の手で並べなおす時、１段階２段階と分けて並べなおすでしょうか？
多分しない、条件として、含ませて並べ替えを行ってます。

・＜の場合：無条件で並べ替え
・＝の場合：次の条件のda?のところを比較して並べ替え

通常のソートであれば、「＜の場合」だけを使用しますが、複合した場合、単純に複合した条件を追記してます

参考ＶＢＡは、バブルソートですので、データ数が多い場合、違うソートで組みなおしたほうが良いかもしれません
（コードがおかしいかもしれませんが・・・ご自身で見直してみてください＾＾；）

Sub SampleSort()

Dim I, J As Long
Dim n01, n02, n03, n04, n05 As Variant

Const StCol = 1
Const StRow = 10
Const NumCn = 6

With ActiveSheet
I = NumCn - 1
Do While I >= 2
J = StCol
Do While J <= I
n01 = .Cells(StRow, J * 2 - 1).Value
n02 = .Cells(StRow, J * 2).Value
n03 = .Cells(StRow + 1, J * 2 - 1).Value
n04 = .Cells(StRow + 1, J * 2).Value
n05 = .Cells(StRow + 2, J * 2 - 1).Value
If n03 > .Cells(StRow + 1, (J + 1) * 2 - 1).Value Or _
(n03 = .Cells(StRow + 1, (J + 1) * 2 - 1).Value And _
n05 > .Cells(StRow + 2, (J + 1) * 2 - 1).Value) Then
.Cells(StRow, J * 2 - 1).Value = _
.Cells(StRow, (J + 1) * 2 - 1).Value
.Cells(StRow, J * 2).Value = _
.Cells(StRow, (J + 1) * 2).Value
.Cells(StRow + 1, J * 2 - 1).Value = _
.Cells(StRow + 1, (J + 1) * 2 - 1).Value
.Cells(StRow + 1, J * 2).Value = _
.Cells(StRow + 1, (J + 1) * 2).Value
.Cells(StRow + 2, J * 2 - 1).Value = _
.Cells(StRow + 2, (J + 1) * 2 - 1).Value
.Cells(StRow, (J + 1) * 2 - 1).Value = n01
.Cells(StRow, (J + 1) * 2).Value = n02
.Cells(StRow + 1, (J + 1) * 2 - 1).Value = n03
.Cells(StRow + 1, (J + 1) * 2).Value = n04
.Cells(StRow + 2, (J + 1) * 2 - 1).Value = n05
End If
J = J + 1
Loop
I = I - 1
Loop
End With

End Sub

回答No.2

zap35

全くもってEXCEL向きではない表ですね(^^;
並べ替えた結果はどのようにしても良いのですが、元のデータは
Ａ列　　Ｂ列　　Ｃ列
　５　　佐藤　　da8
のように表を作成するべきです。そうすれば並べ替えも簡単にできます。並べ替えた結果をマクロで追加シートに展開するのは比較的簡単でしょう。（そうでないと配列定数を使用する必要があるのでマクロも難しくなります）

マクロの勉強中だそうですからマクロにしますが、以下は追加シートに一旦、上記作業用の表を作成し、値を展開し直すものです。

Sub Macro3()
Dim idx As Integer
Dim ShtNM As String
　ShtNM = ActiveSheet.Name
　Worksheets.Add
　With Sheets(ShtNM)　'一旦作業表を作成する
　　For idx = 1 To .Range("IV1").End(xlToLeft).Column Step 2
　　　If .Cells(1, idx) = "" Then
　　　　Exit For
　　　Else
　　　　ActiveSheet.Cells(4 + Int(idx / 2), "A").Value = .Cells(1, idx)
　　　　ActiveSheet.Cells(4 + Int(idx / 2), "B").Value = .Cells(1, idx).Offset(0, 1).Value
　　　　ActiveSheet.Cells(4 + Int(idx / 2), "C").Value = .Cells(1, idx).Offset(1, 0).Value
　　　End If
　　Next idx
　End With

　With ActiveSheet　'作業表を並べ替えてから表示形式に展開
　　.Cells(4, "A").CurrentRegion.Sort Key1:=Range("A4"), Order1:=xlAscending　
　　For idx = 4 To .Range("A65536").End(xlUp).Row
　　　.Cells(1, (idx - 4) * 2 + 1) = .Cells(idx, "A").Value
　　　.Cells(1, (idx - 4) * 2 + 1).Offset(0, 1) = .Cells(idx, "B").Value
　　　.Cells(1, (idx - 4) * 2 + 1).Offset(1, 0) = .Cells(idx, "C").Value
　　Next idx
　　.Cells(4, "A").CurrentRegion.ClearContents
　　.Cells(1, "A").Select
　End With
End Sub

回答No.1

driverII

こういう場合は、

１.３行２列毎にブロック番号を仮につけます。

1 2 3 4 5 6

２.そして２行目の数・daに続く数でソートします。

3 5 6 1 2 4

３．別の場所に、ブロックのデータをコピーして、最後に元の位置に貼り付けます。

ソートの方法については、お好きなものをネットで検索してください。