突出显示单元格中是否有 2 个不同的值

Question

would anyone be able to help? I am trying to write VBA to highlight if the cell has 2 different values. It seems to highlight all including the same name appear twice. Thanks for any help!

Sub CountTwoOrMoreDifferent()
Dim myRange As Long
myRange = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:A" & myRange).Select
For Each AnimalName In Selection
    AnimalNameMoreThan2 = AnimalName.Value
    If InStr(AnimalNameMoreThan2, "Cat") + _
    InStr(AnimalNameMoreThan2, "Dog") + _
    InStr(AnimalNameMoreThan2, "Cow") _
    + InStr(AnimalNameMoreThan2, "Chicken") + _
    InStr(AnimalNameMoreThan2, "Snake") + _
    InStr(AnimalNameMoreThan2, "Tums") + _
    InStr(AnimalNameMoreThan2, "Drop") > 1 Then
    AnimalName.Interior.Color = vbRed
    End If
    Next AnimalName
End Sub

Data in column A

Sample Data

Answer 1

You can use this code.

It is split into two parts

• a sub - which does the check per cell.
• a function that checks if there is a duplicate within an array. It returns true in case there is at least one dup.

Public Sub highlightDuplicateValues()

'get Range to check
Dim lastRow As Long, rgToCheck As Range
With ActiveSheet
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rgToCheck = .Range("A2:A" & lastRow)        'no need to select!
End With

Dim c As Range, arrValuesInCell As Variant
Dim i As Long

For Each c In rgToCheck.Cells
    'get an array of values/animals in cell
    arrValuesInCell = Split(c.Value, ";")
    
    'now check for each value if it has a dup - if yes color red and exit check
    For i = LBound(arrValuesInCell) To UBound(arrValuesInCell)
        If hasDupInArray(arrValuesInCell, i) = True Then
            c.Interior.Color = vbRed
            Exit For
        End If
    Next
Next

End Sub

Private Function hasDupInArray(arrValues As Variant, checkI As Long) As Boolean

'only values after the checkI-value are checked.
'Assumption: previous values have been checked beforehand

Dim varValueToCheck As Variant
varValueToCheck = arrValues(checkI)

Dim i As Long
For i = checkI + 1 To UBound(arrValues)
    If arrValues(i) = varValueToCheck Then
        hasDupInArray = True
        Exit For
    End If
Next
End Function