エクセルで元データとは別のシートに分類別にデータを振り分け表示する方法をご教示ください

エクセルについてご教示ください。

シート1：元データ
A B C
1 ｲﾆｼｬﾙ 出身国 スコア
2 LH アメリカ 95
3 KH スイス 93
4 KS オーストラリア 92
5 SS イギリス 90
6 AG 中国 88
7 AYK 日本 86
8 DD シンガポール 80
9 MT 日本 78
10 TH アメリカ 72
11 TW アメリカ 70

シート2：出身国別データ
A B C
1 出身国 ｲﾆｼｬﾙ スコア
2 アメリカ
3 　アメリカ LH 95
4 　アメリカ TH 72
5 　アメリカ TW 70
6
7 日本
8 　日本 AYK 86
9 　日本 MT 78
10
11 イギリス
12 　イギリス SS 90
13
14 オーストラリア
15 　オーストラリア　KS　　　92
16
17 シンガポール
18 　シンガポール DD 80
19
20 スイス
21 　スイス 　　　　KH 93
22
23 中国
24 　中国 AG 88

シート１ような元データがあり、それをシート２に示しているように出身国別にデータを並べ変えたいと思います。
その時の条件としては、
① 国別に振り分ける際、数の多い順(この場合ですとアメリカ)、その次に国名のあいうえお順（もしくはアルファベット順）、最後にスコア順にしたい。
② シート2には、国別のヘッダー(シート２の２，７，１１、１４、１７、２０、２３行)を入れ、国と国の間には1行空白を入れる。可能であれば、ヘッダーは太文字やアンダーラインなど書式設定を入れたい。

特に②のようなことは設定可能でしょうか。
よろしくご教示くださいますようお願い申し上げます！

なお、元データを更新する度に自動的にシート２に反映する必要があるため、手作業で調整が必要となるオートフィルタ―ではない方法でお願いいたします。

No.1 回答者： mike_g 回答日時： 2015/08/25 15:55

ピボテ(PivotTable Report)の機能を利用するのが“比較的”簡単だけど、“若干”手作業が必要です。

完全自動化は無理難題というものです。ただし、マクロ音痴な私の勝手な思い込み。

この回答へのお礼

早速ご回答をありがとうございます！ピボットテーブルがありましたね。やってみます！
ご回答、本当にありがとうございました！！

お礼日時：2015/08/26 00:56

No.2 ベストアンサー 回答者： tom04 回答日時： 2015/08/25 21:00

こんばんは！

VBAになりますが、一例です。

尚、Sheet3を作業用のSheetとして使用していますので、
Sheet3は使っていない状態にしておいてください。
Sheet2の1行目は項目名が入っているという前提です。

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

Sub Sample1() 'この行から//
Dim i As Long, lastRow As Long, myRow As Long
Dim myArea As Range, myRng As Range, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2") '←Sheet2は実際のSheet名に！★//
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
lastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(lastRow, "C")).Clear
End If
With Worksheets("Sheet1") '←Sheet1は実際のSheet名に！★//
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(.Cells(2, "D"), .Cells(lastRow, "D")).Formula = "=IF(COUNTIF(B$2:B2,B2)=1,COUNTIF(B:B,B2),"""")"
Set myArea = Range(.Cells(1, "A"), .Cells(lastRow, "D"))
.Range("A1").AutoFilter field:=4, Criteria1:=">0"
myArea.SpecialCells(xlCellTypeVisible).Copy
wS3.Range("A1").PasteSpecial Paste:=xlPasteValues
.AutoFilterMode = False
.Range("D:D").ClearContents
wS3.Range("A1").CurrentRegion.Sort key1:=wS3.Range("D1"), order1:=xlDescending, _
key2:=wS3.Range("B1"), order2:=xlAscending, Header:=xlYes
wS3.Range("D:D").Clear
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "B")
wS3.Range("E:G").ClearContents
myArea.SpecialCells(xlCellTypeVisible).Copy wS3.Range("E1")
wS3.Range("E1").CurrentRegion.Sort key1:=wS3.Range("G1"), _
order1:=xlDescending, Header:=xlYes
myRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row + 2
With wS2.Cells(myRow, "A")
.Value = wS3.Cells(i, "B")
.Font.Bold = True
.Font.Underline = True
End With
lastRow = wS3.Cells(Rows.Count, "E").End(xlUp).Row
Set myRng = Range(wS3.Cells(2, "E"), wS3.Cells(lastRow, "E"))
myRng.Offset(, 1).Copy wS2.Cells(myRow + 1, "A")
myRng.Copy wS2.Cells(myRow + 1, "B")
myRng.Offset(, 2).Copy wS2.Cells(myRow + 1, "C")
Next i
wS2.Columns.AutoFit
.AutoFilterMode = False
End With
wS3.Cells.Clear
Application.ScreenUpdating = True
wS2.Activate
MsgBox "完了"
End Sub 'この行まで

※　関数でないのでSheet1のデータ変更があるたびにマクロを実行する必要があります。
※　じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

こんばんは！ご丁寧な回答をありがとうございます！VBAは初めてでしたが、ご指示いただいた通りにできました。コードを組むのは難しそうですが、これを機に勉強させていただきます。
ありがとうございました！！

お礼日時：2015/08/26 00:58

No.3 回答者： 30246kiku 回答日時： 2015/08/26 21:54

解決されたみたいですが、まだ閉じられていなかったので

参考になるところがあればですが

アクティブシートの A1 の CurrentRegion を処理します
結果は新規シートに出力します


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

　　Set dic = CreateObject("Scripting.Dictionary")

　　vA = Range("A1").CurrentRegion.Value
　　For i = 2 To UBound(vA)
　　　　If (Not dic.Exists(vA(i, 2))) Then
　　　　　　dic.Add vA(i, 2), CreateObject("Scripting.Dictionary")
　　　　End If
　　　　j = dic(vA(i, 2)).Count
　　　　dic(vA(i, 2))(j) = Array(vA(i, 1), vA(i, 3))
　　Next

　　ReDim vB(1 To dic.Count)
　　i = 1
　　For Each v In dic.Keys
　　　　vB(i) = Array(v, dic(v).Count)
　　　　i = i + 1
　　Next

　　Application.ScreenUpdating = True
　　Worksheets.Add
　　Cells(1, "A").Resize(, 3) = Array(vA(1, 2), vA(1, 1), vA(1, 3))
　　i = 2
　　For Each v In mySort(vB)
　　　　ReDim vA(1 To v(1) + 1, 1 To 3)
　　　　vA(1, 1) = v(0)
　　　　j = 1
　　　　For Each vv In mySort(dic(v(0)).Items)
　　　　　　j = j + 1
　　　　　　vA(j, 1) = v(0)
　　　　　　vA(j, 2) = vv(0)
　　　　　　vA(j, 3) = vv(1)
　　　　Next
　　　　With Cells(i, "A")
　　　　　　.Resize(j, 3) = vA
　　　　　　.Font.Bold = True
　　　　End With
　　　　i = i + j + 1
　　Next
　　Columns.AutoFit
　　Application.ScreenUpdating = True

　　Set dic = Nothing
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i)(1) < vA(j)(1)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　ElseIf (vA(i)(1) = vA(j)(1)) Then
　　　　　　　　If (vA(i)(0) > vA(j)(0)) Then
　　　　　　　　　　v = vA(i)
　　　　　　　　　　vA(i) = vA(j)
　　　　　　　　　　vA(j) = v
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function

No.4 回答者： 30246kiku 回答日時： 2015/08/27 11:54

＃３です

以下訂正です

>　　Application.ScreenUpdating = True
>　　Worksheets.Add

↓
　　Application.ScreenUpdating = False ' ★
　　Worksheets.Add

この回答へのお礼

ありがとうございます。修正までご教示いただき本当にありがとうございます。
参考にさせていただきます。

お礼日時：2015/09/07 08:37