Excel リスト整理のマクロ

質問

Excelのマクロでリストを整理したいのですが、上手いやり方が見つかりません。

以下のように２つのシートにそれぞれ項目A、項目Bがあり、数字がリストされています。
並び方は、項目Aが１であるもので項目Bの数字が小さいものから並べ、
項目Aが１のものが終われば、項目Aが２のもので同じように項目Bの数字が小さいものから
並べ、以後それを繰り返しています。

Sheet1　　　　　　　　　Sheet2
項目A　項目B 項目A　項目B
　１　　　　１　　　　　　　　１　　　　１
　２　　　　１　　　　　　　　１　　　　２
　２　　　　２　　　　　　　　２　　　　２
　２　　　　３　　　　　　　　２　　　　４
　　　　　　　　　　　　　　　３　　　　２
　３　　　　３　　　　　　　　３　　　　３

上のリストを、マクロを使って下のリストのようにしたいと思っています。

Sheet1 Sheet2
項目A　項目B　　　　　項目A　項目B
　１　　　　１　　　　　　　　１　　　　１
　　　　　　　　　　　　　　　１　　　　２
　２　　　　１　　　　　　
　２　　　　２　　　　　　　　２　　　　２
　２　　　　３
　　　　　　　　　　　　　　　２　　　　４
　　　　　　　　　　　　　　　３　　　　２
　３　　　　３　　　　　　　　３　　　　３

つまり、同じ項目Aおよび項目Bを持つ行はそれぞれ同じ行に並べ、
片方の項目Aおよび項目Bと同じ項目A・Bをもう片方のリストが持たない場合は
その行を空白にしたいのです。　
どなたかお分かりになる方いらっしゃいましたらご教授頂けますと幸いです。
よろしくお願いします。

回答No.1

tom04 · ベストアンサー

こんばんは！
一例です。

両SheetともデータはA・B列にあるとします。
尚、Sheet3を作業用のSheetとして使用していますので、
Sheet3は全く使用していない状態にしておいてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, endRow1 As Long, endRow2 As Long, c As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False
With Range(wS1.Cells(2, "C"), wS1.Cells(endRow1, "C"))
.Formula = "=IF(A2="""","""",A2&""_""&B2)"
.Value = .Value
End With
With Range(wS2.Cells(2, "C"), wS2.Cells(endRow2, "C"))
.Formula = "=IF(A2="""","""",A2&""_""&B2)"
.Value = .Value
End With
wS3.Range("A1") = "ダミー"
Range(wS1.Cells(2, "C"), wS1.Cells(endRow1, "C")).Copy wS3.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Range(wS2.Cells(2, "C"), wS2.Cells(endRow2, "C")).Copy wS3.Cells(Rows.Count, "A").End(xlUp).Offset(1)
wS3.Range("A:A").Sort key1:=wS3.Range("A1"), order1:=xlAscending, Header:=xlYes
For i = wS3.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(wS3.Range("A:A"), wS3.Cells(i, "A")) > 1 Then
wS3.Cells(i, "A").Delete shift:=xlUp
End If
Next i

For i = wS1.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
Set c = wS3.Range("A:A").Find(what:=wS1.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
k = c.Row
wS1.Cells(i, "A").Resize(, 2).Cut wS1.Cells(k, "A")
End If
Next i
For i = wS2.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
Set c = wS3.Range("A:A").Find(what:=wS2.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
k = c.Row
wS2.Cells(i, "A").Resize(, 2).Cut wS2.Cells(k, "A")
End If
Next i
wS1.Range("C:C").ClearContents
wS2.Range("C:C").ClearContents
wS3.Cells.Clear
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m