Sub ColorMe()
On Error Resume Next
c = InputBox("请输入列标", , "C")
r = Cells(65536, c).End(xlUp).Row
arr = Cells(1, c).Resize(r, 1).Value
'获取重复次数
Set d = CreateObject("scripting.dictionary")
For i = 1 To r
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
'判断是否需要上色并随机出颜色值
ks = d.keys
its = d.items
For i = 0 To UBound(ks)
If its(i) > 1 Then
d.Item(ks(i)) = RGB(Int(Rnd * 99) + 99, Int(Rnd * 99) + 99, Int(Rnd * 99) + 99)
Else
d.Item(ks(i)) = xlNone
End If
Next
'逐行查字典赋予颜色值
t = Cells(1, 256).End(xlToLeft).Column
For i = 1 To r
Cells(i, 1).Resize(1, t).Interior.Color = d(arr(i, 1))
Next
Set d = Nothing
End Sub