|
一例です。
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
|
|