Sub Highlight_Duplicate()
Dim c As Range, v As Variant, dict As Object, w As String
For Each c In Range("[COLOR=#0000ff]B[/COLOR]2", Range("[COLOR=#0000ff]B[/COLOR]" & Rows.Count).End(xlUp))
Set dict = CreateObject("scripting.dictionary")
c.Interior.Color = xlNone
For Each v In Split(c, ",")
w = Trim(v)
If Not dict.exists(w) Then
dict(w) = Empty
Else
c.Interior.Color = vbGreen
Exit For
End If
Next
Next
End Sub
| Excel 2016 | |||
|---|---|---|---|
| A | |||
| 1 | abc,123,def | ||
| 2 | 123,def,abc | ||
| 3 | xyz, abc | ||
| 4 | abc,123,def | ||
Sheet1 | |||
Try this in a copy of your workbook.
Sub Dupes()
Dim d As Object
Dim a As Variant, itm As Variant
Dim i As Long, k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("A1", Range("A" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i, 1), ",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i, 1), ",")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End SubSub Highlight_Duplicate()
Dim b() As Variant, v As Variant, m As Variant
Dim r As Range, c As Range
Dim n As Long, i As Long, j As Long, q As Long
Application.ScreenUpdating = False
Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
r.Interior.Color = xlNone
r.Font.ColorIndex = xlAutomatic
n = 1
m = Evaluate("=SUMPRODUCT(LEN(" & r.Address & ")-LEN(SUBSTITUTE(" & r.Address & ","","","""")))")
ReDim b(1 To (m + r.Rows.Count), 1 To 3)
For Each c In r
q = 1
For Each v In Split(c, ",")
b(n, 1) = Trim(v)
b(n, 2) = c.Row
b(n, 3) = q
q = q + Len(v) + 1
n = n + 1
Next
Next
For i = 1 To UBound(b)
For j = 1 To UBound(b)
If b(i, 1) = b(j, 1) And b(i, 2) <> b(j, 2) Then
r.Cells(b(i, 2)).Interior.Color = vbGreen
r.Cells(b(i, 2)).Characters(InStr(b(i, 3), r.Cells(b(i, 2)), b(i, 1)), Len(b(i, 1))).Font.Color = 12406516
Exit For
End If
Next
Next
End SubSet rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
