| 
    
     |  | ▼まさひで さん: 
 1)データを1個ずつ辞書に登録
 2)新規シートに登録結果を書き出し
 3)回数の多い順に並べ替え
 4)回数の多いものトップ5でフィルター
 
 Sub test()
 Dim dic As Object
 Dim c As Range
 
 Set dic = CreateObject("scripting.dictionary")
 
 For Each c In Range("a1").CurrentRegion   '★データ範囲
 dic(c.Value) = dic(c.Value) + 1
 Next
 
 With Worksheets.Add
 .Range("a1:b1").Value = Array("番号", "回数")
 .Range("a2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
 .Range("b2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
 
 With .Range("a1").CurrentRegion
 .Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlYes
 .AutoFilter Field:=2, Criteria1:="5", Operator:=xlTop10Items
 End With
 End With
 
 End Sub
 
 |  |