Find duplicaties based on cell colour

Hi guys,

I'm having difficulties with creating a macro. The scenario: The macro needs to search in column I for a cell with a red background (Interior.ColorIndex = 3). Then it needs to search for duplicates of the value from that same cell in column I. If there's a match, then it needs to give it the same color.

Example:
Cell I1 until I13 have white background. Cell I14 has a red background with value 125. The macro needs to search in column I for value 125 and colour it red.

I hope that you can help me.

Cheers,

Flunzy

If I'm understanding your request correctly, then the following should do the trick:

Sub SpreadRed()
Dim i As Long
Dim LR As Long
Dim RedNo As Long

Application.ScreenUpdating = False
LR = Cells(Rows.Count, "I").End(xlUp).Row
For i = 2 To LR
    If Cells(i, "I").Interior.ColorIndex = 3 Then
        RedNo = Cells(i, "I").Value
        Exit For
    End If
Next i
Range("I1:I" & LR).AutoFilter Field:=1, Criteria1:=RedNo
Range("I2:I" & LR).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

Note that the procedure above presumes that your data in column I has a header...

Originally Posted by cantosh

If I'm understanding your request correctly, then the following should do the trick:

Sub SpreadRed()
Dim i As Long
Dim LR As Long
Dim RedNo As Long

Application.ScreenUpdating = False
LR = Cells(Rows.Count, "I").End(xlUp).Row
For i = 2 To LR
    If Cells(i, "I").Interior.ColorIndex = 3 Then
        RedNo = Cells(i, "I").Value
        Exit For
    End If
Next i
Range("I1:I" & LR).AutoFilter Field:=1, Criteria1:=RedNo
Range("I2:I" & LR).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

Note that the procedure above presumes that your data in column I has a header...

Dear Cantosh,

Thanks for all the effort but it doesn't work 100%. It works for the first lines but not for the rest of the file. I've added an example file where you can test it. You will see that the code works from line 30 until 38 but it doesn't work on line 46, 85, 141 and 148.

Originally Posted by flunzy

It works for the first lines but not for the rest of the file.

Thanks for the clarification! My initial understanding was that there would only be one red cell, which is why my initial effort only caught the first one. Shifting the order of a few of my lines should fix that:

Sub SpreadRed()
Dim i As Long
Dim LR As Long
Dim RedNo As Long

Application.ScreenUpdating = False
LR = Cells(Rows.Count, "I").End(xlUp).Row
For i = 2 To LR
    If Cells(i, "I").Interior.ColorIndex = 3 Then
        RedNo = Cells(i, "I").Value
        Range("I1:I" & LR).AutoFilter Field:=1, Criteria1:=RedNo
        Range("I2:I" & LR).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
        ActiveSheet.AutoFilterMode = False
    End If
Next i
Application.ScreenUpdating = True
End Sub

Originally Posted by cantosh

Thanks for the clarification! My initial understanding was that there would only be one red cell, which is why my initial effort only caught the first one. Shifting the order of a few of my lines should fix that:

Sub SpreadRed()
Dim i As Long
Dim LR As Long
Dim RedNo As Long

Application.ScreenUpdating = False
LR = Cells(Rows.Count, "I").End(xlUp).Row
For i = 2 To LR
    If Cells(i, "I").Interior.ColorIndex = 3 Then
        RedNo = Cells(i, "I").Value
        Range("I1:I" & LR).AutoFilter Field:=1, Criteria1:=RedNo
        Range("I2:I" & LR).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
        ActiveSheet.AutoFilterMode = False
    End If
Next i
Application.ScreenUpdating = True
End Sub

Thanks Cantosh for the new code. I'll keep yours as the second code for the case. Thanks for all the effort : ) Als a rep for you : D

Originally Posted by jindon

Try

Sub test()
    Dim r As Range
    With CreateObject("Scripting.Dictionary")
        For Each r In Range("i1", Range("i" & Rows.Count).End(xlUp))
            If r.Interior.ColorIndex = 3 Then
                .Item(r.Value) = Empty
            Else
                If .exists(r.Value) Then r.Interior.ColorIndex = 3
            End If
        Next
    End With
End Sub

or not first appeared cell is colored.

Sub test()
    Dim r As Range, ff As String, x(), n As Long
    Application.ScreenUpdating = False
    With Application.FindFormat
        .Clear
        .Interior.ColorIndex = 3
    End With
    With Range("i1", Range("i" & Rows.Count).End(xlUp))
        Set r = .Find("*", searchformat:=True)
        If Not r Is Nothing Then
            ff = r.Address
            Do
                n = n + 1: ReDim Preserve x(1 To n): x(n) = r.Value
                Set r = Columns("i").Find("*", r, searchformat:=True)
            Loop Until ff = r.Address
            .AutoFilter 1, x, 7
            .Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 3
            .AutoFilter
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Hi Jindon,

Once again, you save the day : D thanks a lot : ) the code works like a charm. Reputation point is coming your way : D

double post....