|
こんな書き方もあるかもしれないです。
Sub test()
Dim myR As Range, Mycell As Range
Dim dic, key
Dim k As Long
Dim v As String
Dim region As String
Set myR = Range("C2" & ":" & "C" & Range("C" & Rows.Count).End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
For Each Mycell In myR
v = Mycell.Value
region = Mycell.Offset(, -1).Value
If v <> "" Then
If dic.Exists(v) Then
If InStr(dic(v), region) = 0 Then 'これは不要かも
dic(v) = dic(v) & region & ","
End If
Else
dic(v) = region & ","
End If
End If
Next
k = 1
For Each key In dic.Keys
k = k + 1
Cells(k, "G").Value = UBound(Split(dic(key), ","))
Cells(k, "H").Value = key
Cells(k, "I").Value = Left(dic(key), Len(dic(key)) - 1)
Next
Set dic = Nothing
End Sub
|
|