Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'modified from code by taurean
Static sOldRng As Range
Dim ThisRow As Long, LastCol As Long, ValueCount As Long
Dim r As Range, c As Range, d As Range
Dim m, e
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
ThisRow = Target.Row
LastCol = ActiveSheet.Cells(ThisRow, Columns.Count).End(xlToLeft).Column
If Not sOldRng Is Nothing Then
With sOldRng
.Font.ColorIndex = xlColorIndexAutomatic
.Interior.ColorIndex = xlColorIndexNone
End With
Set sOldRng = Nothing
End If
With ActiveSheet
Set m = CreateObject("scripting.dictionary")
'Start with the values in the original row
For Each c In .Range(.Cells(ThisRow, 1), .Cells(ThisRow, LastCol))
If (Not m.Exists(c.Value)) And c.Value <> "" And c.Value <> 0 Then m.Add c.Value, 1
Next c
'as each cell is checked, add all values from that row to m, skipping values that are already there
'repeat until nothing new is added
Do
ValueCount = m.Count
For Each e In m
For Each r In .UsedRange
If r.Value = e Then
LastCol = ActiveSheet.Cells(r.Row, Columns.Count).End(xlToLeft).Column
For Each d In .Range(.Cells(r.Row, 1), .Cells(r.Row, LastCol))
If (Not m.Exists(d.Value)) And d.Value <> "" And d.Value <> 0 Then m.Add d.Value, 1
Next d
End If
Next r
Next e
Loop While m.Count > ValueCount 'this means something got added
'this goes through all the values again, so it's not particularly efficient, but it seems to work
For Each r In .UsedRange
For Each e In m
If r.Value = e Then
If sOldRng Is Nothing Then
Set sOldRng = r
Else
Set sOldRng = Union(sOldRng, r)
End If
End If
Next e
Next r
End With
If Not (sOldRng Is Nothing) Then
With sOldRng
.Font.Color = vbRed
.Interior.Color = vbYellow
End With
End If
End Sub
:
