Highlighting rows random colors if there duplicates one column - PART 2

[mortenkl]

Hello all,

Yesterday I got a lot of help from this thread:

http://www.mrexcel.com/forum/excel-...om-colors-if-there-duplicates-one-column.html

I managed to get my spreadsheet highlighting working using the code provided in that thread:

Sub ColourDuplicates()
Dim Rng As Range
Dim Cel As Range
Dim Cel2 As Range
Dim Colour As Long

Set Rng = Worksheets("NY Fakturering").Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
Rng.Interior.ColorIndex = xlNone
Colour = 19

For Each Cel In Rng

If WorksheetFunction.CountIf(Rng, Cel) > 1 And Cel.Interior.ColorIndex = xlNone Then
Set Cel2 = Rng.Find(Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchDirection:=xlNext)
    If Not Cel2 Is Nothing Then
        Firstaddress = Cel2.Address
        Do
        Cel.Offset(0, -1).Resize(1, 31).Interior.ColorIndex = Colour
        Cel2.Offset(0, -1).Resize(1, 31).Interior.ColorIndex = Colour

           Set Cel2 = Rng.FindNext(Cel2)
        
        Loop While Firstaddress <> Cel2.Address
        
    End If

Colour = Colour + 1

End If

Next

End Sub

I'm very satisfied with the result, but thought: Would it be possible to only switch between two colours? Like:

firstColour = 19
secondColour = 20

Any help adjusting the code is much appreciated, if possible.

Sorry if this should be in the original thread, but it's about 6 months old. Feel free to merge them if needed.

Thank you.

/ Morten

 

[Trebor76]

Like this?:

Option Explicit
Sub ColourDuplicates()

    Dim Rng As Range
    Dim Cel As Range
    Dim Cel2 As Range
    Dim Colour As Long
    Dim Firstaddress As String
    
    Set Rng = Worksheets("NY Fakturering").Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
    Rng.Interior.ColorIndex = xlNone
    'Colour = 19
    
    For Each Cel In Rng
    
        If WorksheetFunction.CountIf(Rng, Cel) > 1 And Cel.Interior.ColorIndex = xlNone Then
            Set Cel2 = Rng.Find(Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchDirection:=xlNext)
                If Not Cel2 Is Nothing Then
                    Firstaddress = Cel2.Address
                    If Colour = 0 Or Colour = 19 Then
                        Colour = 20
                    Else
                        Colour = 19
                    End If
                    Do
                    Cel.Offset(0, -1).Resize(1, 31).Interior.ColorIndex = Colour
                    Cel2.Offset(0, -1).Resize(1, 31).Interior.ColorIndex = Colour
            
                       Set Cel2 = Rng.FindNext(Cel2)
                    
                    Loop While Firstaddress <> Cel2.Address
                    
                End If
            
            'Colour = Colour + 1
    
        End If
    
    Next Cel
    
End Sub

Regards,

Robert

 

[My Aswer Is This]

..

 

[mortenkl]

Like this?:

< snip >

Regards,

Robert

Exactly like this! Thank you, Robert. Much appreciated

/ Morten

 

[Trebor76]

You're welcome and thanks for the like