Highlighting rows with random colors if there are duplicates in one column

[korak30]

Hello, I'd like to highlight rows with random colors if there are duplicates (anywhere between 3-10) in one of the columns. My data set looks like this:

1_800_flowerscom	1 Old Country Rd Ste 500	Carle Place	NY	11514-1847	United States
1_800_flowerscom	1 Old Country Rd Ste 500	Carle Place	NY	11514-1847	USA
1_automotive_group	950 Echo Lane	Houston	TX	77024-2756	United States
1_automotive_group	800 Gessner Rd Ste 500	Houston	TX	77024-4498	United States
1_automotive_group	950 Echo Lane	Houston	TX	77024-2756	United States of America
1_chambers_court_family_garden_law
1_chambers_court_family_garden_law	1 Garden Court Temple	London		EC4Y 9BJ	United Kingdom

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

Basically I'd like to highlight the rows, for duplicate values in column A, with a unique color. The reason I need a random color is because there are 17000 rows.

I've tried some basic conditional formatting but that's not working.

Any help is much appreciated. Thanks!

 

[farmerscott]

For the matches, test-

Sub CheckMatches()



Dim lr As Long
Dim x As Long

lr = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row

For x = 1 To lr

    If Cells(x, 2).Value = Cells(x + 1, 2) And Cells(x, 2).Value = Cells(x + 2, 2).Value Then
        Number = 0
        If Cells(x, 10).Value = Cells(x + 1, 10).Value And Cells(x, 10).Value = Cells(x + 2, 10).Value Then
         Number = Number + 1
         End If
         
         If Cells(x, 11).Value = Cells(x + 1, 11).Value And Cells(x, 11).Value = Cells(x + 2, 11).Value Then
         Number = Number + 1
         End If
        
         If Cells(x, 13).Value = Cells(x + 1, 13).Value And Cells(x, 13).Value = Cells(x + 2, 13).Value Then
         Number = Number + 1
         Cells(x, 27).Value = Number
        End If
        x = x + 2
        GoTo J
    Else
    If Cells(x, 2).Value = Cells(x + 1, 2) Then
        Number = 0
        If Cells(x, 10).Value = Cells(x + 1, 10).Value Then
         Number = Number + 1
         Cells(x, 27).Value = Number
         End If
         
         If Cells(x, 11).Value = Cells(x + 1, 11).Value Then
         Number = Number + 1
         Cells(x, 27).Value = Number
         End If
         
         If Cells(x, 13).Value = Cells(x + 1, 13).Value Then
         Number = Number + 1
         Cells(x, 27).Value = Number
         End If
        
  End If
  End If
J:


       Next x
       End Sub

It is not perfect but it starts getting us in the ball park.
In each of your groupings (on Col B) what is the maximum number of matches do you expect. The code assumes a max of 3.

 

[korak30]

I think that's working for the matches! Um, I'm not sure about the max number though, I've seen it up to 17 while randomly scrolling down, but then again there are 17000 rows so there might be a case where there is more than 20 of these duplicates.

 

[farmerscott]

Hi Korak,

I think I have found the problem. I had the colour, looping as it finds the other matches. I assume there is, only so many colours that VBA can generate this way. Hence you will see that the colours are now being randomly generated, and hopefully solved this problem.

This time the colouring went down to row 17,265.

The updated code is below. Try it.

Sub ColourDuplicates2()
Dim Rng As Range
Dim Cel As Range
Dim Cel2 As Range
Dim Colour As Long
 
Set Rng = Worksheets("Remaining Groups").Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
Rng.Interior.ColorIndex = xlNone
 
 
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)
    Colour = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
    If Not Cel2 Is Nothing Then
       
        Firstaddress = Cel2.Address
        Do
       
        Cel.Offset(0, -1).Resize(1, 26).Interior.Color = Colour
        Cel2.Offset(0, -1).Resize(1, 26).Interior.Color = Colour
 
           Set Cel2 = Rng.FindNext(Cel2)
           
        Loop While Firstaddress <> Cel2.Address
    End If
 
 
End If
Next
 
End Sub

I am awaiting some expert guidance for the next part of your problem- doing the matches on cols J,K & M.

cheers.

 

[korak30]

That's awesome!! Thank you so much!!

Honestly, if the second part of the problem is another macro that is completely okay - it does not have to be part of the same macro.

Also, just out of curiosity, is it weird having to code using American English spelling, but naturally having tendencies to use British English spelling?

 

[farmerscott]

Korak,

Yes Excel (being US centric) has a bit of a trap for us English spelling minions!!!

These following codes are separate from the "Colour Duplicates 2" code above. The end result is the checking of Col J, K & M. It is not in the format you exactly want but gets us going forward towards your goal.

I have tested the following codes on the data you sent and it seems to be working.

Before you run the first code make sure you have a "Sheet1" which is blank, as the code writes an array to that sheet. The array provides references of when your data changes within Col G. Note: these numbers are not direct row numbers.

Sub GetRows2()
'adapted from code by ChrisM


Dim lr As Long
Dim aSrc As Variant
Dim aResults() As Variant   'item, start row, stop row
Dim i As Long, k As Long
Dim sCurrVal As String




lr = Sheets("Remaining Groups").Cells(Sheet1.Rows.Count, "G").End(xlUp).Row


aSrc = Sheets("Remaining Groups").Range("G2:G" & lr) 'automatically load array from range




sCurrVal = aSrc(1, 1) 'aCurrVal becomes the first value in the array, of 1 col wide.
ReDim aResults(1 To 3, 1 To 1)
aResults(1, 1) = sCurrVal 'load first value
aResults(2, 1) = 2
k = 1 'result counter
 
For i = 1 To UBound(aSrc, 1) 'start looping thru array from sheet
    If aSrc(i, 1) <> sCurrVal Then
        'write stop row value
        aResults(3, k) = i - 1
        sCurrVal = aSrc(i, 1)
        'load result array
        k = k + 1
        ReDim Preserve aResults(1 To 3, 1 To k)
        aResults(1, k) = sCurrVal
        aResults(2, k) = i
    End If
Next i
aResults(3, k) = i  'this will capture the last entry




'now write result array to worksheet in 3 columns
Sheets("Sheet1").Range("A1").Resize(k, 3) = Application.Transpose(aResults)


End Sub

Then run the following code which does the analysis on your columns-

Sub check_columns()


Dim x As Long
Dim y As Long
Dim Rng As Range
Dim Arr As Variant
Dim Arr2 As Variant






lr = Sheets("Sheet1").Cells(Sheet1.Rows.Count, "A").End(xlUp).Row


Arr = Sheets("Sheet1").Range("A2:C" & lr)


For i = 1 To UBound(Arr, 1) 'checking Col J
 
Value1 = Arr(i, 1)
Value2 = Arr(i, 2)
Value3 = Arr(i, 3)
            
Value4 = Value3 - Value2 + 1 'get difference in row numbers


If Value4 <> 1 Then
Arr2 = Sheets("Remaining Groups").Range(Cells(Value2 + 1, 10), Cells(Value3 + 1, 10))


CurVal = Arr2(1, 1)


For e = 1 To UBound(Arr2, 1)
   
    If Arr2(e, 1) = CurVal Then
    
    n = n + 1
    End If
Next e


    If n = Value4 Then 'all data in that column matches
        Sheets("Remaining Groups").Cells(Value2 + 1, 27).Value = "Col J Matches"
        Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 27).Value = "Col J Does Not Match"
     End If
     n = 0
     ReDim Arr2(1 To 1, 1 To 1)
Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 27).Value = "only 1 entry"
End If
Next i


For i = 1 To UBound(Arr, 1) 'checking col K
 


Value1 = Arr(i, 1)
Value2 = Arr(i, 2)
Value3 = Arr(i, 3)
            
Value4 = Value3 - Value2 + 1 'get difference in row numbers


If Value4 <> 1 Then
Arr2 = Sheets("Remaining Groups").Range(Cells(Value2 + 1, 11), Cells(Value3 + 1, 11))


CurVal = Arr2(1, 1)


For e = 1 To UBound(Arr2, 1)
   
    If Arr2(e, 1) = CurVal Then
    
    n = n + 1
    End If
Next e


    If n = Value4 Then 'all data in that column matches
        Sheets("Remaining Groups").Cells(Value2 + 1, 28).Value = "Col K Matches"
        Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 28).Value = "Col K Does Not Match"
     End If
     n = 0
     ReDim Arr2(1 To 1, 1 To 1)
Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 27).Value = "only 1 entry"
End If
Next i


For i = 1 To UBound(Arr, 1) 'checking Col M
 


Value1 = Arr(i, 1)
Value2 = Arr(i, 2)
Value3 = Arr(i, 3)
            
Value4 = Value3 - Value2 + 1 'get difference in row numbers


If Value4 <> 1 Then
Arr2 = Sheets("Remaining Groups").Range(Cells(Value2 + 1, 13), Cells(Value3 + 1, 13))


CurVal = Arr2(1, 1)


For e = 1 To UBound(Arr2, 1)
   
    If Arr2(e, 1) = CurVal Then
    
    n = n + 1
    End If
Next e


    If n = Value4 Then 'all data in that column matches
        Sheets("Remaining Groups").Cells(Value2 + 1, 29).Value = "Col M Matches"
        Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 29).Value = "Col M Does Not Match"
     End If
     n = 0
     ReDim Arr2(1 To 1, 1 To 1)
Else
        Sheets("Remaining Groups").Cells(Value2 + 1, 27).Value = "only 1 entry"
End If
Next i
End Sub

Hope this helps.

And a big thanks to ChrisM for his original code and help with this.

FarmerScott

 

[korak30]

Beautiful!

Thank you so much, Scott and ChrisM! I think this will work for my needs right now. I cannot express how grateful I am!

Last quick question: Is it possible to run the two macros as one, by adding the second one right below the first?

Best,

 

[farmerscott]

Glad it is working for you.

To join the up the codes just remove 'end sub' on the first part and 'Sub check_columns()' on the second part. It may not be pretty but it should work.

cheers.

 

[mortenkl]

Hello all,

First off - sorry for opening an old thread.

I found this thread very helpful as I needed to color similar rows. I did a copy / paste of the code provided here and it works.... almost . Here are the code:

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 = 6

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, 26).Interior.ColorIndex = Colour
Cel2.Offset(0, -1).Resize(1, 26).Interior.ColorIndex = Colour

Set Cel2 = Rng.FindNext(Cel2)

Loop While Firstaddress <> Cel2.Address
End If

Colour = Colour + 4

End If
Next

End Sub

It seems that the formatting stop working on columns after Z - look at the picture below:

Any help is much appreciated. Thank you.

/ Morten

 

[korak30]

Cel.Offset(0, -1).Resize(1, 26).Interior.ColorIndex = Colour
Cel2.Offset(0, -1).Resize(1, 26).Interior.ColorIndex = Colour

Perhaps the issue is in those two lines - when you re-size you specify 26 columns, maybe change that number to the actual number of columns you want highlighted?

Let me know if that works! I'm still not too great but that's my best attempt upon quick inspection.

 

[mortenkl]

Cel.Offset(0, -1).Resize(1, 26).Interior.ColorIndex = Colour
Cel2.Offset(0, -1).Resize(1, 26).Interior.ColorIndex = Colour

Perhaps the issue is in those two lines - when you re-size you specify 26 columns, maybe change that number to the actual number of columns you want highlighted?

Let me know if that works! I'm still not too great but that's my best attempt upon quick inspection.

Thanks! This was exactly what needed to be done