Find duplicaties based on cell colour

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