Sub Uniquedata()
Dim rCell As Range
'创建Dictionary对象
Set d = CreateObject("Scripting.Dictionary")
'遍历数据区域的单元格
For Each rCell In Range("A2:I905")
'判断单元格是否为空
If rCell <> "" Then
'如果Dictionary对象中不包含指定的关键字就添加该关键字和条目
If Not d.exists(rCell.Value) Then d.Add rCell.Value, rCell.Value
End If
Next
'清除指定列内容
Range("J2:J" & Range("J2").End(xlDown).Row).ClearContents
'将Dictionary对象中的条目写入指定列
Range("J2").Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
End Sub