Highlight or flag duplicate values in the same cell

[fredtriest]

I was hoping someone could assist with a macro or formula that will help in highlighting or flagging a single cell that has duplicate values. I haven't had any luck with the macros I've found mostly due to them conflicting with the "and" or "&"

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Harvey, Mary, Kathy and Harvey[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]John and John[/TD]
[/TR]
</tbody>[/TABLE]

Thanks!

 

[JoeMo]

This assumes there are only duplicates, no triplicates or beyond, and that sub-strings within a cell are comma-space or just space delimited. Select the cells you want to highlight first, then run the macro. Duplicates will be highlighted in bold red font.

Sub HiliteDupsInCellBoldRed()
'select the cells of interest first, then run this macro
Dim c As Range, Parts As Variant, i As Long, j As Long
Application.ScreenUpdating = False
For Each c In Selection
    If Not IsEmpty(c) And InStr(c.Value, " ") > 0 Then
        Parts = Split(Replace(c.Value, ",", ""), " ")
        For i = LBound(Parts) To UBound(Parts) - 1
            For j = i + 1 To UBound(Parts)
                If Parts(j) = Parts(i) Then
                    With c.Characters(InStrRev(c.Value, Parts(j)), Len(Parts(j)))
                        .Font.Bold = True
                        .Font.Color = vbRed
                    End With
                End If
            Next j
        Next i
    End If
Next c
Application.ScreenUpdating = True
End Sub

EDIT: Forgot to mention, this will only work on cells containing constants, not on cells with formulas in them.

 

[NARAYANK991]

Hi ,

Another option :

Public Sub HighlightDuplicates()
           Dim lastrow As Long, i As Long
           Dim inputdatarange As Range, cell As Range
           Dim inputarray As Variant
           Dim cellval As String, currstring As String, currword As String, newword As String
           Dim matchpos1 As Integer, matchpos2 As Integer, lenpos1 as Integer


           On Error GoTo errorexit:
           
           With Application
                .ScreenUpdating = False
                .EnableEvents = False
           End With
           
           lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
           Set inputdatarange = ActiveSheet.Range("A1:A" & lastrow)
           
           For Each cell In inputdatarange
               cellval = cell.Value
               currstring = Replace(Replace(cellval, " and ", ","), " ", "")
               inputarray = Split(currstring, ",")
               
               For i = 0 To UBound(inputarray)
                   currword = inputarray(i)
                   matchpos1 = InStr(1, cellval, currword, vbTextCompare)
                   lenword1 = Len(currword)
                   For j = i + 1 To UBound(inputarray)
                       newword = inputarray(j)
                       If VBA.StrComp(currword, newword, vbTextCompare) = 0 Then
                          matchpos2 = InStr(matchpos1 + lenword1, cellval, newword, vbTextCompare)
                          
                          cell.Characters(matchpos1, lenword1).Font.Bold = True
                          cell.Characters(matchpos2, lenword1).Font.Bold = True
                          matchpos1 = matchpos2
                       End If
                   Next
               Next
           Next


errorexit:
           With Application
                .ScreenUpdating = True
                .EnableEvents = True
           End With
End Sub

 

[fredtriest]

Both of these are great!! I hate to ask for more, but is it possible to take into consideration criteria such as:

Highlight a cell when names start with the first 3 letters? For example, it would catch "Dave" and "David" as a duplicate.

 

[JoeMo]

Untested but this should highlight a word whose first 3 letters duplicate the first 3 letters of a word appearing earlier in the string within a cell. Select the cells for highlighting first, then run the macro.

Sub HiliteDupsInCellBoldRed3()
'select the cells of interest first, then run this macro
Dim c As Range, Parts As Variant, i As Long, j As Long
Application.ScreenUpdating = False
For Each c In Selection
    If Not IsEmpty(c) And InStr(c.Value, " ") > 0 Then
        Parts = Split(Replace(c.Value, ",", ""), " ")
        For i = LBound(Parts) To UBound(Parts) - 1
            For j = i + 1 To UBound(Parts)
                If Left(Parts(j), 3) = Left(Parts(i), 3) Then
                    With c.Characters(InStrRev(c.Value, Parts(j)), Len(Parts(j)))
                        .Font.Bold = True
                        .Font.Color = vbRed
                    End With
                End If
            Next j
        Next i
    End If
Next c
Application.ScreenUpdating = True
End Sub

 

[fredtriest]

Perfect, thank you!!!!

 

[JoeMo]

Perfect, thank you!!!!

You are welcome - thanks for the reply.