| 
    
     |  | 一例です。 
 Sub test()
 Dim dic As Object
 Dim r As Range
 Dim s As String
 Dim name As String
 
 Set dic = CreateObject("Scripting.Dictionary")
 
 '氏名、得点に基づき、該当する得点ランク別のdictionaryに氏名を保持
 For Each r In Range([A1], [A1].End(xlDown))
 name = r.Value
 s = getRank(r.Offset(, 1).Value)
 If Not dic.exists(s) Then
 Set dic(s) = CreateObject("Scripting.Dictionary")
 End If
 dic(s)(name) = Empty
 Next
 
 Columns("D").ClearContents
 
 'カンマで文字列連結して書き出し
 For Each r In Range([C1], [C1].End(xlDown))
 If dic.exists(r.Value) Then
 r.Offset(, 1).Value = Join(dic(r.Value).keys, ",")
 End If
 Next
 
 End Sub
 
 '得点毎のランクを得る(得点は整数と仮定)
 Function getRank(v As Long) As String
 Select Case v
 Case Is >= 90: getRank = "90〜100"
 Case Is >= 70: getRank = "良"
 Case Is >= 50: getRank = "可"
 Case Else: getRank = "不可"
 End Select
 End Function
 
 |  |