VBA Code To Highlight Duplicate Values In A Column

[shonu]

Hello,

My current vba code is finding the duplicate strings however only if they are in a sequence which is one after another. If it is out of sequence it does not work. So if the word Walter is repeated one after another it works. However if you put John in between it does not work. Please see the below code I have:

Sub FindDups ()
   
   ScreenUpdating = False
   FirstItem = ActiveCell.Value
   SecondItem = ActiveCell.Offset(1, 0).Value
   Offsetcount = 1
   Do While ActiveCell <> ""
      If FirstItem = SecondItem Then
        ActiveCell.Offset(Offsetcount,0).Interior.Color = RGB(255,0,0)
        Offsetcount = Offsetcount + 1
        SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
      Else
        ActiveCell.Offset(Offsetcount, 0).Select
        FirstItem = ActiveCell.Value
        SecondItem = ActiveCell.Offset(1,0).Value
        Offsetcount = 1
      End If
   Loop
   ScreenUpdating = True
End Sub

[MARK858]

If you are try to highlight all the duplicates then you can try the code below. It is set up for Column C, to change the column change the bits in red

Sub DupIt()
Dim Rng As Range
Dim cel As Range
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
    For Each cel In Rng
        If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
            cel.Interior.ColorIndex = 3
        End If
    Next cel
End Sub

[LalitPandey87]

You can also try this:-

Option Explicit


 Sub lm()
 
    Dim rngRange            As Range
    Dim rngFirstRange       As Range
    Dim rngToFind           As Range
    
    Const strStringToFind   As String = "a"
    
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngToFind = .Range("A1").CurrentRegion
        With rngToFind
            Set rngRange = .Find(strStringToFind, LookIn:=xlValues, lookat:=xlWhole)
            If Not rngRange Is Nothing Then
                Set rngFirstRange = rngRange
                Do
                    rngRange.Interior.ColorIndex = 3
                    Set rngRange = .FindNext(rngRange)
                Loop While Not rngRange Is Nothing And rngRange.Address <> rngFirstRange.Address
            End If
        End With
    End With
    
    Set rngRange = Nothing
    Set rngFirstRange = Nothing
    Set rngToFind = Nothing
 
 End Sub

[Admin]

Hi

If you are 2007+ then why don't use conditional formatting to highlight duplicates ?

[shonu]

Thanks Everyone, using excel 2003 unfortunately at work....

[MARK858]

Thanks Everyone, using excel 2003 unfortunately at work....

The codes in posts #2 and #3 are 2003 compatible. Did they not work for you?
If not what are your issues with the codes?

[Rick Rothstein]

If the data in Column C (the column I am assuming you want to check for doubles... change the highlighted C's to the actual column letter for your data) is all text, that is, no formulas, then here is one more macro for you to try (this one uses no loops and should be fast... no promises on that though)...

Sub MarkDuplicates()
  Dim Addr As String
  Addr = "C1:C" & Cells(Rows.Count, "C").End(xlUp).Row
  Range(Addr) = Evaluate("IF(COUNTIF(" & Addr & "," & Addr & ")>1,""=""&" & Addr & "," & Addr & ")")
  On Error Resume Next
  Range(Addr).SpecialCells(xlFormulas).Interior.ColorIndex = 6
  Range(Addr).Replace "=", "", xlPart
End Sub

By the way, if your data column does contain formulas, I can modify the code to account for that... just let me know.