Sub Macro1()
Dim arr, i, j
Dim d As Object, mkey
Dim mHight, s
'On Error Resume Next
Set d = CreateObject("scripting.dictionary")
d.CompareMode = TextCompare
arr = Range("A1:E21")
For j = 1 To 5
For i = 1 To UBound(arr)
If Len(arr(i, j)) <> 0 Then
d(arr(i, j)) = d(arr(i, j)) & "," & Chr(j + 64) & i
End If
Next
Next
For Each mkey In d.keys
If UBound(Split(d(mkey), ",")) > 1 Then
mHight = mHight + 16
s = mkey & "有重复,位置为:" & Mid(d(mkey), 2) & Chr(10) & s
Dim strCity() As String
strCity = Split(Mid(d(mkey), 2), ",")
For intloop = 0 To UBound(strCity)
Range(strCity(intloop)).Select
x = Int(Rnd() * 255)
y = Int(Rnd() * 255)
Z = Int(Rnd() * 255)
With Selection.Font
'.Color = RGB(x, y, Z)
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(x, y, Z)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next intloop
End If
Next
If mHight = 0 Then
TextBox1.Text = "没有发现重复单元格"
Else
MsgBox (s)
End If
End Sub
