エクセル２０１０で表の複数の並び替え

Aの表をＢの形に並び替え出来る方法を教えて下さい！
A
地方店商品数量１月
愛知Ａ店りんご10
愛知Ａ店バナナ20
岐阜Ａ店みかん15
岐阜Ｂ店バナナ15
三重Ｂ店りんご20
三重Ｃ店バナナ25
三重Ｃ店みかん20
地方店商品数量２月
愛知Ｂ店バナナ15
愛知Ｃ店みかん20
岐阜Ａ店みかん20
三重Ａ店りんご30
三重Ｂ店りんご10
三重Ｂ店バナナ40

↓
B
地方商品数量１月数量２月店
愛知りんご　　10　　　　　Ａ店
三重　　 20　　 Ｂ店
三重　　　　　 30　 Ａ店
三重　　　　　 10 Ｂ店
愛知バナナ　　20　　　　　　　 Ａ店
愛知　　　　　 15 Ｂ店
岐阜　　 15　　 Ｂ店
三重　　 25　　 Ｃ店
三重　　　　　　　　 40 Ｂ店
愛知みかん　　 20 Ｃ店
岐阜　　 15　　 Ａ店
岐阜　　　　　 20Ａ店
三重　　 20　　 Ｃ店

KURUNA

No.1 ベストアンサー 回答者： tom04 回答日時： 2015/01/11 13:20

こんにちは！

VBAになりますが、一例です。
元データはSheet1（↓の画像の左側）にあり、右側のSheet2に表示するとします。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻り（VBE画面を閉じて）マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, lastRow1 As Long, lastRow3 As Long, myRow As Long, lastCol As Long
Dim str As String, c As Range, r As Range, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS2.Cells.Clear
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS3 = Worksheets(Worksheets.Count)
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
wS2.Range("B1") = .Range("A1")
wS2.Range("C1") = .Range("C1")
.Range("A:A").Insert
.Range("A1") = "ダミー"
For i = 1 To lastRow1
If Not IsNumeric(.Cells(i, "E")) Then
str = .Cells(i, "E")
Else
.Cells(i, "A") = str
End If
Next i
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
.Range("D:D").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("B1"), unique:=True
wS3.Range("B1") = "ダミー"
wS3.Range("B:B").Replace what:="商品", replacement:="", lookat:=xlWhole
wS3.Range("A:B").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
lastRow3 = wS3.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS3.Cells(2, "A"), wS3.Cells(lastRow3, "A")).Copy
wS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
lastCol = wS2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
wS2.Cells(1, lastCol) = .Range("C1")
For i = 2 To wS3.Cells(Rows.Count, "B").End(xlUp).Row
.Range("A1").AutoFilter field:=4, Criteria1:=wS3.Cells(i, "B")
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow1, "E")).SpecialCells(xlCellTypeVisible).Copy _
wS3.Range("C1")
For k = 1 To wS3.Cells(Rows.Count, "C").End(xlUp).Row
Set c = wS2.Range("A:A").Find(what:=wS3.Cells(k, "C") & wS3.Cells(k, "D") & _
wS3.Cells(k, "E") & wS3.Cells(k, "F"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
myRow = wS2.UsedRange.Rows.Count + 1
wS2.Cells(myRow, "A") = wS3.Cells(k, "C") & wS3.Cells(k, "D") & wS3.Cells(k, "E") & wS3.Cells(k, "F")
Else
myRow = c.Row
End If
Set r = wS2.Rows(1).Find(what:=wS3.Cells(k, "C"), LookIn:=xlValues, lookat:=xlWhole)
wS2.Cells(myRow, "B") = wS3.Cells(k, "D")
wS2.Cells(myRow, "C") = wS3.Cells(k, "F")
wS2.Cells(myRow, r.Column) = wS3.Cells(k, "G")
wS2.Cells(myRow, lastCol) = wS3.Cells(k, "E")
Next k
wS3.Range("C:G").Clear
End If
Next i
.AutoFilterMode = False
.Range("A:A").Delete
wS2.Range("A:A").Delete
Application.DisplayAlerts = False
wS3.Delete
Application.ScreenUpdating = True
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
wS2.Columns.AutoFit
wS2.Activate
wS2.Range("A1").Select
For i = wS2.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If wS2.Cells(i, "B") = wS2.Cells(i - 1, "B") Then
wS2.Cells(i, "B").ClearContents
End If
Next i
End With
Application.ScreenUpdating = True
End Sub 'この行まで

※　関数でないので、データ変更があるたびにマクロを実行する必要があります。m(_ _)m

この回答へのお礼

tom04様へ
ご丁寧な回答有難うございます。
とてもレベルの高い回答ですね！
作業後の表も完璧デス１
こんな私に出来るでしょうか？
１度トライしてみます！
どうも有難うございました♪
　　　　　　　　　KURUNA

お礼日時：2015/01/11 17:38