Find duplicates in a list and hightlight with color either row or cells

[dprivitelli]

Dear All,

Could you provide me with some help for the following problem.

I have a list of about 500 Items in a particular column let's say A. What I want is a Macro to identify duplicates in the list and highlight in a particular colour the whole row of all occurances of the same ITEM. Obviously there may be different sets of duplicates and therefore to distinguish them I need a different colour for each set. I also want a check to verify that all items have a character length of 12 and if not highlights the particular cells in 1 single character for all. Could you please help me?

Thanks and Regards.

 

[Gerald Higgins]

Do you really need a different colour for each pair ?
Worst case is that your data consists of 250 pairs, so 250 different colours, and I would guess it's going to be difficult to visually match through 250 different colours.

If you want to identify pairs of duplicates, there are probably better ways of doing it.
How about just sorting your data using col A as the primary sort field ?
Then use a helper column to identify your duplicates, such as

=if(A1=A2,"duplicate","")

If the current sequence is important, insert another helper column before you do the sortation, and in this column insert an index number which will allow you to re-sort afterwards.

 

[dprivitelli]

I want to limit user intervention as possible...... What I want is that as soon as the user opens the file.... the sorting, cell text length and duplicates are already identified and easily marked for the user in such away to save time by query immediately the problems identified........... the if statement won't do the job for me................ I would like an iteration process to check the complete list for duplicates and text length.....

 

[Gerald Higgins]

Ah, some additional requirements . . . .

Well, you could apply my solution through an auto-execute macro.

It would probably help if you can describe your requirements really clearly please.

 

[dprivitelli]

So.......

I have a list of codes made up of alphanumeric characters sometimes of 500, 600, 700, depending on the shop reporting these items. Obviously each row contains first of all the ITEM CODE and then additional details in the following columns.

Now what I want is first of all to check each ITEM code to see whether it contains 12 characters. If not the particular ITEM CELL is highlighted in yellow. Then what I want is to highlight those entire rows which are duplicates. Each pair is to be highlighted in a random colour as long as pairs have the same colour. There will not be a lot, maybe 4 to 5 duplicate item codes so there will not be the problem you mentioned of a huge number of colours.

Would you be guide me through a code snippet/macro capable of doing so please?

Thanks & Regards

 

[dprivitelli]

Any news about the issue please?

 

[Trebor76]

Hi ,

Interesting concept!!

Try this - just change the setting of the 'rngMyData' variable to suit, if need be:

Option Explicit
Sub Macro1()

    'http://www.mrexcel.com/forum/showthread.php?t=590419

    Dim objUniqueItems As Object
    Dim varUniqueItem As Variant
    
    Dim rngCell As Range, _
        rngMyData As Range, _
        rngFoundCell As Range, _
        rngLastCell As Range
    Dim strFirstAddr As String
    
    Dim bteRed As Byte, _
        bteGreen As Byte, _
        bteBlue As Byte
        
    Application.ScreenUpdating = True
    
    Set objUniqueItems = CreateObject("Scripting.Dictionary")
    Set rngMyData = ActiveSheet.Range("A2:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row) 'Range A2:A[last row in Col A]. Change to suit.
    
    Randomize 'Without this, the RGB numbers will always be displayed in the same order.
        
    With ActiveSheet
    
        For Each rngCell In rngMyData
    
            If Len(rngCell.Value) > 0 Then
                
                If Not objUniqueItems.Exists(rngCell.Value) Then
                    objUniqueItems.Add rngCell.Value, rngCell.Value
                End If
                
            End If
                
        Next rngCell
        
        For Each varUniqueItem In objUniqueItems.keys
        
            'Randomly select a number from 0 to 255 (inclusive) for the 3 colour variables.
            bteRed = Int(255 + 1) * Rnd()
            bteGreen = Int(255 + 1) * Rnd()
            bteBlue = Int(255 + 1) * Rnd()
                       
            'The following is based on C. Pearson's code from here: _
            http://www.cpearson.com/Excel/FindAll.aspx
            With rngMyData
                Set rngLastCell = .Cells(.Cells.Count)
            End With
            
            Set rngFoundCell = rngMyData.Find(what:=varUniqueItem, after:=rngLastCell)
            
            If Not rngFoundCell Is Nothing Then
                strFirstAddr = rngFoundCell.Address
            End If
            
            Do Until rngFoundCell Is Nothing
                rngFoundCell.Interior.Color = RGB(bteRed, bteGreen, bteBlue)
                Set rngFoundCell = rngMyData.FindNext(after:=rngFoundCell)
                If rngFoundCell.Address = strFirstAddr Then
                    Exit Do
                End If
            Loop
                
        Next varUniqueItem
        
    End With
    
    Application.ScreenUpdating = False
    
    Set objUniqueItems = Nothing
    Set rngMyData = Nothing
    Set rngFoundCell = Nothing
    Set rngLastCell = Nothing
    
End Sub

HTH

Robert

 

[dprivitelli]

Hi.... first of all thanks for the code....

So...the code you have given me partly works greatly because it highlights same codes with same colour, although only the CELL not the entire ROW is being highlighted in colour.

On the other hand though, I do not want non duplicates to be highlighted and the code is highlighting them as well.

Moreover, I want also that the routine checks and highlights CELLS of those codes which are less than 12 characters in YELLOW and currently the code is not doing so...

Thanks and regards.

 

[MickG]

Try this :-
Sometime, if there's enough data these colours will duplicate or the array might have duplicate colour already, if I've not been diligent !!

[COLOR="Navy"]Sub[/COLOR] MG08Nov44
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Cols [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Rng.EntireRow.Interior.ColorIndex = xlNone
Cols = Array(6, 3, 4, 7, 15, 16, 17, 19, 22, 24, 28, 31, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 47, 48, 50)
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            n = n + 1
            n = IIf(n = UBound(Cols), 1, n)
            .Add Dn.Value, Array(Dn, Cols(n))
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Value)(0).EntireRow.Interior.ColorIndex = .Item(Dn.Value)(1)
            Dn.EntireRow.Interior.ColorIndex = .Item(Dn.Value)(1)
            [COLOR="Navy"]If[/COLOR] Len(Dn) < 12 [COLOR="Navy"]Then[/COLOR]
                Dn.Interior.ColorIndex = 6
                .Item(Dn.Value)(0).Interior.ColorIndex = 6
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[dprivitelli]

Hi Mick,

Thanks for your feedback. The issue is that the code does not seem to be working as nothing is happening.......... I have duplicates and codes with less than 12 characters and nothing is being highlighted....

Regards,