EXCELのマクロに詳しい方 教えて下さい

EXCELで以下のようなデータを元に表を作成したいのですが、どうすれば良いでしょうか？

データ１（シート１）・個人別所有個数

所属部署コード 社員ＩＤ 　　　所有個数
ABC 　　　　　　12345 　　　30
BCD 　　　　　　23456 　　　25
DEF 　　　　　　34567 　　　40
BBB 　　　　　　44444 　　　20
CCC 　　　　　　55555 　　　15
ABC 　　　　　　12348 　　　20
BCD 　　　　　　22222 　　　80
DEF 　　　　　　33333 　　　30
BBB 　　　　　　55555 　　　100
BCD 　　　　　　23417 　　　50

データ２（シート２）・所属部署名

所属部署コード 　部署名
ABC 　　　　　　　AAABBBCCC
BCD 　　　　　　　BBBCCCDDD
DEF 　　　　　　　DDDEEEFFF
BBB 　　　　　　　BBBXXXYYY
CCC 　　　　　　　CCCAAAXXX

上記のデータ１とデータ２を元に別シートに以下の２つの表を作成したいのです。

表１・所有個数の多い社員から順番に並べる。

所属部署コード 部署名 　　　　社員ＩＤ 　所有個数
BBB 　　　　　　BBBXXXYYY 　55555 　100
BCD 　　　　　　BBBCCCDDD 　22222 　80
BCD 　　　　　　BBBCCCDDD 　23417 　50
DEF 　　　　　　DDDEEEFFF 　34567 　40
ABC 　　　　　　AAABBBCCC 　12345 　30
DEF 　　　　　　DDDEEEFFF 　33333 　30
BCD 　　　　　　BBBCCCDDD 　23456 　25
BBB 　　　　　　BBBXXXYYY 　44444 　20
ABC 　　　　　　AAABBBCCC 　12348 　20
CCC 　　　　　　CCCAAAXXX 　55555 　15

表２・所有個数の多い部署を多い順に並べる

部署名　部署名　　　　　　個数
BCD 　BBBCCCDDD　　　155
BBB 　BBBXXXYYY　　　120
DEF 　DDDEEEFFF 　70
ABC AAABBBCCC 　 50
CCC CCCAAAXXX 　15

以上です。よろしお願いします。

No.1 ベストアンサー 回答者： 30246kiku 回答日時： 2015/09/28 02:53

以下でどうなりますか

データ１のシート名：Sheet1
データ２のシート名：Sheet2
それぞれの表は A1 から出来上がっているものと仮定します


Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant, vB As Variant, v As Variant
　　Dim i As Long, k As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Worksheets("Sheet2")
　　　　vA = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)) _
　　　　　　　　.Resize(, 2).Value
　　End With
　　ReDim Preserve vA(1 To UBound(vA), 1 To 3)
　　vA(1, 3) = "個数"
　　For i = 2 To UBound(vA)
　　　　dic(vA(i, 1)) = i
　　Next

　　With Worksheets("Sheet1")
　　　　vB = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)) _
　　　　　　　　.Resize(, 3).Value
　　End With
　　ReDim Preserve vB(1 To UBound(vB), 1 To 4)
　　vB(1, 4) = vB(1, 3)
　　vB(1, 3) = vB(1, 2)
　　vB(1, 2) = vA(1, 2)
　　For i = 2 To UBound(vB)
　　　　vB(i, 4) = vB(i, 3)
　　　　vB(i, 3) = vB(i, 2)
　　　　k = dic(vB(i, 1))
　　　　If (k > 0) Then
　　　　　　vB(i, 2) = vA(k, 2)
　　　　　　vA(k, 3) = vA(k, 3) + vB(i, 4)
　　　　Else
　　　　　　vB(i, 2) = ""
　　　　End If
　　Next

' ★～
　　Application.ScreenUpdating = False
　　For Each v In Array(vB, vA)
　　　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　　　With Range("A1").Resize(UBound(v), UBound(v, 2))
　　　　　　.Value = v
　　　　　　.Sort .Cells(.Columns.Count), xlDescending _
　　　　　　　　　　, .Cells(1), , xlAscending, Header:=xlYes
　　　　　　With .Rows(1)
　　　　　　　　.Interior.ColorIndex = 15
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　End With
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.EntireColumn.AutoFit
　　　　End With
　　Next
　　Application.ScreenUpdating = True
' ～★

　　Set dic = Nothing
End Sub


上記では、結果を別々のシートに出力していますが
★～　～★　間を以下に変更すると、別シート１枚に連続出力します
出力順は　Array(vB, vA)　の記述順

　　Application.ScreenUpdating = False
　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　i = 1
　　For Each v In Array(vB, vA)
　　　　With Cells(i, "A").Resize(UBound(v), UBound(v, 2))
　　　　　　.Value = v
　　　　　　.Sort .Cells(.Columns.Count), xlDescending _
　　　　　　　　　　, .Cells(1), , xlAscending, Header:=xlYes
　　　　　　With .Rows(1)
　　　　　　　　.Interior.ColorIndex = 15
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　End With
　　　　　　.Borders.LineStyle = xlContinuous
　　　　End With
　　　　i = i + UBound(v) + 1
　　Next
　　Columns.AutoFit
　　Application.ScreenUpdating = True

この回答へのお礼

出来ました。
ありがとうございます！

お礼日時：2015/09/29 00:04