vba code to only highlight contiguous duplicates in one column - vba

Question

I have the following code which highlights contiguous and non-contiguous cells that have the same contents in a single column with different colours. Could this code be modified to highlight only contiguous cells in one column with one colour (e.g. yellow)?
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range
Dim colValue As New Collection
Dim intColor As Integer
Set rngArea = ActiveSheet.Range("F1:F65536")
intColor = 5
On Error Resume Next
For Each rngCellA In rngArea
If rngCellA.Value <> "" Then
Err.Clear
colValue.Add rngCellA.Value, "MB" & rngCellA.Value
If Err = 0 Then
intColor = intColor + 1
For Each rngCellB In rngArea
If rngCellB.Value = rngCellA.Value Then
rngCellB.Interior.ColorIndex = intColor
End If
Next rngCellB
End If
End If
Next rngCellA
End Sub
Assistance with this matter is highly appreciated. Thanks in advance.

Answer 1

The below code will highlight all non-blank and duplicate values for all cells in columns B through F:
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
Dim rngCellB As Range
'Narrow the search area to only that which has been used
Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))
For Each rngCellA In rngArea
'No point in searching for blank cells or ones that have already been highlighted
If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then
Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellA)
'Check if the value in rngCellA exists anywhere else
If Not rngCellB Is Nothing And Not rngCellB.Address = rngCellA.Address Then
'If another does exist, highlight it and every value that duplicates it
rngCellA.Interior.Color = vbYellow
Do While Not rngCellB.Address = rngCellA.Address
rngCellB.Interior.Color = vbYellow
Set rngCellB = rngArea.Find(What:=rngCellA.Value, LookAt:=xlWhole, After:=rngCellB)
Loop
End If
End If
Next rngCellA
End Sub
To only evaluate contiguous cells in the same column I would modify the code as such:
Sub HighlightSameValues()
Dim rngArea As Range
Dim rngCellA As Range
'Narrow the search area to only that which has been used
Set rngArea = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B:F"))
For Each rngCellA In rngArea
'No point in searching for blank cells or ones that have already been highlighted
If Not rngCellA.Value = vbNullString And Not rngCellA.Interior.Color = vbYellow Then
If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
rngCellA.Offset(-1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
rngCellA.Offset(1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If
Next rngCellA
End Sub
This is what coding at 2am gets you with no sleep. =)
I was missing the all important Not in (Not rngCellA.Interior.Color = vbYellow). Also I noticed that I forgot to highlight the first cell identified.
I have retested both code segments and both are now working as intended.
Segment 1 will highlight anything that is duplicated within columns B through F.
Segment 2 will highlight anything that is duplicated only that is contiguous and in the same column.
If your data table starts in row 1 (No header) or goes to the last row available on the sheet:
If Not rngCellA.Row = 1 Then
If rngCellA.Offset(-1, 0).Value = rngCellA.Value Then
rngCellA.Offset(-1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If
If Not rngCellA.Row = ActiveSheet.Rows.Count Then
If rngCellA.Offset(1, 0).Value = rngCellA.Value Then
rngCellA.Offset(1, 0).Interior.Color = vbYellow
rngCellA.Interior.Color = vbYellow
End If
End If