Dim obj As Object
Dim rng As Range

Set obj = CreateObject("Scripting.Dictionary")
For Each rng In Range(検索範囲)
　If rng.Value = Range("a2").Value Then
　　With Cells(rng.Row, "d")
　　　If obj.exists(.Value) = False Then obj.Add .Value, 0
　　End With
　End If
Next
Range("e1").Resize(obj.Count).Value = WorksheetFunction.Transpose(obj.keys)
Set obj = Nothing