上位１０箇所を抽出

質問

エクセル2003を使ってデータベースを構築しています。
Ｒ列にある事象が発生した箇所が入力されています。（Ｒ２セルから下に）
事象が発生した箇所の上位１０箇所を抽出して、それぞれの発生件数を違うシートに貼り付けたいと思っています。
但し、同順位の事象が複数あることもあります。同順位ものがあれば１０箇所を越えていても、抽出したいと思っています。
例えば、1位　○○　100件　
　　　　2位　△△　90件
　　　　3位　□□　80件　ＡＡ　80件
　　　　5位　ＢＢ　70件
　　　　6位　ＣＣ　60件　
　　　　7位　ＤＤ　50件
　　　　8位　ＥＥ　40件
　　　　9位　ＦＦ　30件　ＧＧ　30件　ＨＨ　30件　ＩＩ　30件
こんな感じで10位を越えていても、上記のような結果になれば、上記のように抽出したいと思っています。

これをＶＢＡを使って実現できないでしょうか？

よろしくお願いします。

回答No.3

merlionXX · ベストアンサー

> 構文の説明を頂けないでしょうか？

基本はDictionaryオブジェクトです。
Dictionaryオブジェクトについては
http://officetanaka.net/excel/vba/tips/tips80.htm
などを参照してください。
要は、データの羅列から重複しないリストを作成し、個々の重複しない各データ（Key）に関連付けられるIｔemに出現数をカウントしているだけです。
KeyもItemも配列となるので、それぞれTransposeで縦に変換してB、C列に貼り付けます。
そしてそれを降順に並べ替え、空いているA列にRankを入れ、さらに上位10に入る数値のところまでを残してそれ以下を削除しました。
各コードにコメントをつけました。

Sub test01()
Dim myDic As Object '変数宣言
Dim ms As Worksheet, ns As Worksheet
Dim c As Range, r As Range, dta As String, b As Long

Set myDic = CreateObject("Scripting.Dictionary") 'Dictionaryオブジェクトを準備しmyDicとする
Set ms = Sheets("Sheet1") 'Sheets("Sheet1")をmsとする
Set ns = Sheets("Sheet2") 'Sheets("Sheet2")をnsとする

For Each c In ms.Range(ms.Cells(2, "R"), ms.Cells(Rows.Count, "R").End(xlUp)) 'msのR列の各セルについて
dta = c.Value 'セルのデータをdtaに代入
If Not myDic.exists(dta) Then 'myDicにdtaが存在しなければ
myDic.Add dta, 1 'myDicにKeyとして加え、そのItemを１とする
Else '重複すれば
myDic(dta) = myDic(dta) + 1 'そのKeyのItemに１を加える
End If
Next c '繰り返し
ns.Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) 'nsのB1以下にKeyの配列を転記
ns.Range("C1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Items) 'nsのC1以下にItemの配列を転記
Set myRng = ns.Range("C1:C" & myDic.Count) 'ns.C列データ範囲をmyRngとする
myRng.Offset(0, -1).Resize(, 2).Sort Key1:=ns.Range("C1"), Order1:=xlDescending, Header:=xlNo 'A～C列を並べ替え
b = Application.Large(myRng, 10) 'myRngの10位の値をbに代入
myRng.Offset(0, -2).NumberFormatLocal = "#""位""" 'A列の書式設定（位）
For Each r In myRng 'myRng各セルについて
r.Offset(0, -2).Value = Application.Rank(r.Value, myRng) '左2つ隣（A列）にRank表示
If r.Value < b Then 'b以下なら
ns.Range(r, myRng.Cells(myRng.Count)).EntireRow.Delete 'それ以下の行を削除
Exit For '繰り返しを抜ける
End If
Next r '繰り返し

Set myDic = Nothing '後処理
Set ms = Nothing
Set ns = Nothing
Set myRng = Nothing
End Sub

お礼

お礼が大変遅くなり申し訳ございませんでした。
また、ご丁寧な回答ありがとうございました。

回答No.2

merlionXX

merlionXXです。

ごめんなさい、ミスってました。
修正します。

Sub test01()
Dim myDic As Object
Dim ms As Worksheet, ns As Worksheet
Dim c As Range, r As Range, dta As String, b As Long
Set myDic = CreateObject("Scripting.Dictionary")
Set ms = Sheets("Sheet1")
Set ns = Sheets("Sheet2")
For Each c In ms.Range(ms.Cells(2, "R"), ms.Cells(Rows.Count, "R").End(xlUp))
dta = c.Value
If Not myDic.exists(dta) Then
myDic.Add dta, 1
Else
myDic(dta) = myDic(dta) + 1
End If
Next c
ns.Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys)
ns.Range("C1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Items)
Set myRng = ns.Range("C1:C" & myDic.Count)
myRng.Offset(0, -1).Resize(, 2).Sort Key1:=ns.Range("C1"), Order1:=xlDescending, Header:=xlNo
b = Application.Large(myRng, 10)
myRng.Offset(0, -2).NumberFormatLocal = "#""位"""
For Each r In myRng
r.Offset(0, -2).Value = Application.Rank(r.Value, myRng)
If r.Value < b Then
ns.Range(r, myRng.Cells(myRng.Count)).EntireRow.Delete
Exit For
End If
Next r
Set myDic = Nothing
Set ms = Nothing
Set ns = Nothing
Set myRng = Nothing
End Sub

お礼

前回に引き続き、ご回答頂きありがとうございます。
お陰さまで、今回も解決できそうです。

お手数でなければ、この構文の説明を頂けないでしょうか？
後程、抽出するデータの追加等が発生する可能性がありますので・・・

よろしくお願い致します。

回答No.1

merlionXX

R2以降に「事象発生箇所」名があるシートをSheet1
ベスト10を抽出するシートをSheet2とします。
Sheet2のA列にRANK、B列に「事象発生箇所」、C列に発生数（出現数）を表示します。

Sub test01()
Dim myDic As Object
Dim ms As Worksheet, ns As Worksheet
Dim c As Range, r As Range, dta As String, b As Long
Set myDic = CreateObject("Scripting.Dictionary")
Set ms = Sheets("Sheet1")
Set ns = Sheets("Sheet2")
For Each c In ms.Range(ms.Cells(2, "R"), ms.Cells(Rows.Count, "R").End(xlUp))
dta = c.Value
If Not myDic.exists(dta) Then
myDic.Add dta, 1
Else
myDic(dta) = myDic(dta) + 1
End If
Next c
ns.Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys)
ns.Range("C1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Items)
Set myRng = ns.Range("C1:C" & myDic.Count)
myRng.Sort Key1:=ns.Range("C1"), Order1:=xlDescending, Header:=xlNo
b = Application.Large(myRng, 10)
myRng.Offset(0, -2).NumberFormatLocal = "#""位"""
For Each r In myRng
r.Offset(0, -2).Value = Application.Rank(r.Value, myRng)
If r.Value < b Then
ns.Range(r, myRng.Cells(myRng.Count)).EntireRow.Delete
Exit For
End If
Next r
Set myDic = Nothing
Set ms = Nothing
Set ns = Nothing
Set myRng = Nothing
End Sub