Solved

Excel 2010 - Find Duplicates and mark each with different color in VBA

Posted on 2014-10-18
20
682 Views
Last Modified: 2014-10-21
For a particular workbook, how would one write a macro that has the following conditions:

1. A Primary Worksheet: This contains the cell values to be searched.
    a. This worksheet would have a specific name ("Error Items")

2. A Search Criteria:  The value of each cell, within a range (eg. A7 to  A:Lastrow), within the Primary Worksheet
     a. Only one column of values is contained within the Range

3. A Search Loop:  Through a set of secondary worksheets, to identify any duplicate values
    a. There will be at least two worksheets, with the words "Posted Late" within the name on each Tab, or worksheet, to be searched.

4. Highlighting any Duplicate match that is found: The Interior Color of each cell match, is changed, or highlighted.

5. Each duplicate match has a different Interior Color: The interior color value, is incremented either up or down, so that the next match shows a different interior color of the pair, or set, than the one before it.
   a. The color change doesn't have to totally different, but the color shades should allow it to be easily identified from the others.
 
Thanks,
Cook09
0
Comment
Question by:Cook09
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 12
  • 8
20 Comments
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40390217
Can you supply a sample workbook?
0
 

Author Comment

by:Cook09
ID: 40390807
Attached is a workbook, the question should contain the rest of what is needed.
Error-Report.xlsx
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40390813
Several questions:

1.    Is a VBA solution OK?
2.    In your #2 I assume you mean A10 to  A:Lastrow
3.    What defines a duplicate? The same value in each of the "Posted Late" sheets, or a value in either of the "Posted Late" sheets that matches column A in "Error Items"?
4.    Can the same tracking number appear more than once on a given sheet?
5.    Do you just want the Tracking # highlighted or the whole table row?
0
Save the day with this special offer from ATEN!

Save 30% on the CV211 using promo code EXPERTS30 now through April 30th. The ATEN CV211 connects a laptop directly to any server allowing you instant access to perform data maintenance and local operations, for quick troubleshooting, updating, service and repair.

 

Author Comment

by:Cook09
ID: 40390884
1. Yes I was looking (assuming) that a VBA solution was needed.
2. A10 could be fine, if not, I can modify it if the rows change.
3. A duplicate is where two or more cells, within the criteria range on the "Error Items" worksheet, have the same value (usually it's alphanumeric). While most of the time it will involve only two values, there could be times where maybe it would be three.
4. No, the same tracking number would not be on the same sheet.
5. Only the duplicate tracking numbers would have the interior color changed. This is the reason to have the color shades increase or decrease, with each duplicate found.

The sequence would have each value within the criteria range from the "Error Items" worksheet, and that value would be compared with any worksheet that has the words "Posted Late" in it, or begins with "Posted Late." On some days there could  be four worksheets that fit that category.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40390941
I'm still a bit confused about #3. Given the workbook you posted please give sheet names and cell addresses for one set of duplicates.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40390962
Make a copy of your workbook and then add and run this macro and let me know if it's what you want.

Sub FindDulicates()
Dim lngRow As Long
Dim lngRowPL As Long
Dim lngIndex As Long
Dim lngColor As Long
Dim strErrorData() As String
Dim ws As Worksheet
Dim colErrors As Collection
Dim rngStart As Range

lngColor = 100

Set rngStart = Sheets("Error Items").Cells.Find(What:="Tracking #", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
If rngStart Is Nothing Then
    MsgBox "Sub heading with the value of 'Tracking #' not found"
    Exit Sub
End If
For lngRow = rngStart.Row + 1 To Sheets("Error Items").UsedRange.Rows.Count
    Set colErrors = New Collection
    For Each ws In Worksheets
        With ws
            If InStr(1, .Name, "Posted Late") > 0 Then
                For lngRowPL = 1 To ws.UsedRange.Rows.Count
                    If .Cells(lngRowPL, 1) = Sheets("Error Items").Cells(lngRow, 1) Then
                        colErrors.Add ws.Name & "|" & lngRowPL
                    End If
                Next
            End If
        End With
    Next
    If colErrors.Count > 1 Then
        lngColor = lngColor + 50
        For lngIndex = 1 To colErrors.Count
            strErrorData = Split(colErrors(lngIndex), "|")
            Sheets(strErrorData(0)).Cells(strErrorData(1), 1).Interior.Color = lngColor
        Next
    End If
Next
End Sub

Open in new window


To find the starting row in Error Items it looks for "Tracking #" and you can have as many "Posted Late" sheets as you like.
0
 

Author Comment

by:Cook09
ID: 40392069
It didn't work with today's workbook and I tried it with the sample...well you can see that it missed most of them.  The Criteria Tracking # should also be highlighted.  Maybe that's why it seemed to miss most of them.  But, to know that there is a match with the Error and Posted Late, they both need to be highlighted.
Error-Report-Sample1.xlsx
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40392183
I'm sorry that I did so poorly. I misunderstood what qualified as a duplicate. I have that fixed but the problem now is that some of the colors that get assigned to the duplicates are too dark to read the text. I can correct that but if you could give me an idea of the maximum entries there might be on the Error Items sheet it would help.
0
 

Author Comment

by:Cook09
ID: 40392200
The maximum entries could be 25-30.   However, if we combine a months worth of data, then it could be a lot large.  The idea behind the color shades, is for easier identification of like items. Maybe after "x" shades of red, then it changes to blue for "X" shades. etc.  If there is an easier way to do this, then I'm open to ideas.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40392595
This is tough but I'm getting there.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40392787
Try this. You may need to experiment with dblTint (and it's increments) and intColor to get acceptable cell colors. As posted you can have 364 sets of duplicates with unique colors. After that the colors repeat.

Dim lngRow As Long
Dim lngRowPL As Long
Dim lngIndex As Long
Dim strErrorData() As String
Dim ws As Worksheet
Dim colErrors As Collection
Dim rngStart As Range
Dim intColor As Integer
Dim dblTint As Double

intColor = 5
dblTint = -0.6

Set rngStart = Sheets("Error Items").Cells.Find(What:="Tracking #", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
If rngStart Is Nothing Then
    MsgBox "Sub heading with the value of 'Tracking #' not found"
    Exit Sub
End If
For lngRow = rngStart.Row + 1 To Sheets("Error Items").UsedRange.Rows.Count
    Set colErrors = New Collection
    For Each ws In Worksheets
        With ws
            If InStr(1, .Name, "Posted Late") > 0 Then
                For lngRowPL = 1 To ws.UsedRange.Rows.Count
                    If .Cells(lngRowPL, 1) = Sheets("Error Items").Cells(lngRow, 1) Then
                        colErrors.Add lngRow & "|" & ws.Name & "|" & lngRowPL
                    End If
                Next
            End If
        End With
    Next
    If colErrors.Count > 0 Then
        For lngIndex = 1 To colErrors.Count
            strErrorData = Split(colErrors(lngIndex), "|")
            ' Step through the colors and the tints.
            ' There are 56 colors. I skipped the first few because they don't look goog.
            ' Each color can have a tint value ranging from -1 (the darkest) to +1 (the lightest).
            If dblTint > 0.75 Then ' It's too light
                dblTint = -0.4 ' The darkest readable tint
                intColor = intColor + 1
                If intColor > 56 Then
                    MsgBox "Too many duplicates to color individually. Starting over with the same colors"
                    intColor = 3
                End If
            Else
                dblTint = dblTint + 0.2
            End If
            Sheets("Error Items").Cells(strErrorData(0), 1).Interior.ColorIndex = intColor
            Sheets("Error Items").Cells(strErrorData(0), 1).Interior.TintAndShade = dblTint
            Sheets(strErrorData(1)).Cells(strErrorData(2), 1).Interior.ColorIndex = intColor
            Sheets(strErrorData(1)).Cells(strErrorData(2), 1).Interior.TintAndShade = dblTint

        Next
    End If
Next
End Sub 

Open in new window

0
 

Author Comment

by:Cook09
ID: 40392935
It seems to work with one exception, and I'm not sure how to put a "And Not" statement within the statement that you have.  But it highlights three items that shouldn't be:
1. The Text -- "Tracking #"
2. The Text -- "Total Items:"
3. The Empty Cell under each "Posted Late"  and "Error Items" Section. What is interesting is that the empty cell between the Sections is highlighted with its own seperate color, there are no two colors the same.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40393125
Sorry I missed your last post and I will get back to you about it but take a look at the attached workbook that contains an alternative approach which is a sheet called Duplicate Items and it contains hyperlinks to the duplicates. The example report shows only the first duplicate Tracking # and if that tracking number were in all three sheets there would be another hyperlink in range B3, and, of course, there would be entries for all the duplicate tracking numbers in column A.
Q-28540012.xlsm
0
 

Author Comment

by:Cook09
ID: 40393196
I like the alternative, that would work as well. The only difference really is that one could look at the Error Items worksheet and see which ones did  not have duplicates.  But a total could be added at the bottom of column A to show how many did have duplicates.  This could work....although, I'm still interested, in concept at least, how to put a "And Not," with the Collection.
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40393249
It seems to work with one exception, and I'm not sure how to put a "And Not" statement within the statement that you have.  But it highlights three items that shouldn't be:
1. The Text -- "Tracking #"
2. The Text -- "Total Items:"
3. The Empty Cell under each "Posted Late"  and "Error Items" Section. What is interesting is that the empty cell between the Sections is highlighted with its own seperate color, there are no two colors the same.
I don't see any of that happening when I run it. What's different about the layout of the workbook I have when compared to your workbook?

What the macro does at the start is to find the "Tracking #" string on the Error Items sheet and then adds one to that row giving A10 which it uses as the starting row of the tracking numbers so I don't see how it is highlighting range A9.

Attached is a workbook where I just ran the macro.
Q-28540012.xlsm
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40393269
However you could try this version where I've added code to bypass cells with the 3 values you mention.

Sub FindDulicates()
Dim lngRow As Long
Dim lngRowPL As Long
Dim lngIndex As Long
Dim strErrorData() As String
Dim ws As Worksheet
Dim colErrors As Collection
Dim rngStart As Range
Dim intColor As Integer
Dim dblTint As Double

intColor = 5
dblTint = -0.6

Set rngStart = Sheets("Error Items").Cells.Find(What:="Tracking #", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
If rngStart Is Nothing Then
    MsgBox "Sub heading with the value of 'Tracking #' not found"
    Exit Sub
End If
For lngRow = rngStart.Row + 1 To Sheets("Error Items").UsedRange.Rows.Count
    If Sheets("Error Items").Cells(lngRow, 1).Value <> "Tracking #" And _
            Sheets("Error Items").Cells(lngRow, 1).Value <> "Total Itms:" And _
            Trim(Sheets("Error Items").Cells(lngRow, 1).Value) <> "" Then
        Set colErrors = New Collection
        For Each ws In Worksheets
            With ws
                If InStr(1, .Name, "Posted Late") > 0 Then
                    For lngRowPL = 1 To ws.UsedRange.Rows.Count
                        If .Cells(lngRowPL, 1) = Sheets("Error Items").Cells(lngRow, 1) Then
                            colErrors.Add lngRow & "|" & ws.Name & "|" & lngRowPL
                        End If
                    Next
                End If
            End With
        Next
        If colErrors.Count > 0 Then
            For lngIndex = 1 To colErrors.Count
                strErrorData = Split(colErrors(lngIndex), "|")
                ' Step through the colors and the tints.
                ' There are 56 colors. I skipped the first few because they don't look goog.
                ' Each color can have a tint value ranging from -1 (the darkest) to +1 (the lightest).
                If dblTint > 0.75 Then ' It's too light
                    dblTint = -0.4 ' The darkest readable tint
                    intColor = intColor + 1
                    If intColor > 56 Then
                        MsgBox "Too many duplicates to color individually. Starting over with the same colors"
                        intColor = 3
                    End If
                Else
                    dblTint = dblTint + 0.2
                End If
                Sheets("Error Items").Cells(strErrorData(0), 1).Interior.ColorIndex = intColor
                Sheets("Error Items").Cells(strErrorData(0), 1).Interior.TintAndShade = dblTint
                Sheets(strErrorData(1)).Cells(strErrorData(2), 1).Interior.ColorIndex = intColor
                Sheets(strErrorData(1)).Cells(strErrorData(2), 1).Interior.TintAndShade = dblTint
    
            Next
        End If
    End If
Next
End Sub

Open in new window

0
 

Author Comment

by:Cook09
ID: 40394783
It does work better,  but on the attached workbook, it bypasses one of the Posted Late worksheets 10.11 I think, thereby missing a couple of duplicates.  Plus, "Tracking Itms:" was renamed to "Tracking Items:".
Error-Log-Report-Sample.xlsx
0
 
LVL 47

Accepted Solution

by:
Martin Liss earned 500 total points
ID: 40394981
Here is your most recent workbook back where I've run both the FindDuplicates and the new ErrorRpt macros. I don't see that I've missed anything, but if you disagree please let me know the Tracking # from the Error Items sheet, the name of the sheet where the duplicate is found, and the cell address of the duplicate on that sheet.
Error-Log-Report-Sample.xlsm
0
 

Author Comment

by:Cook09
ID: 40395401
Thanks for your efforts and help, having both provides some flexibility.  I figured out why there were certain issues with not getting all of the duplicates.  If the ActiveCell was not where it should be, then the results will be different.  Attached is the workbook with the changes that were made.

The code also checks to see if the worksheet "Duplicate Errors," is present.  Given that it's almost like a TOC for errors, I put it in front.

Again, thanks, it works well.
Error-Log-Report-Sample1.xlsm
0
 
LVL 47

Expert Comment

by:Martin Liss
ID: 40395590
You're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2014
0

Featured Post

MS Dynamics Made Instantly Simpler

Make Your Microsoft Dynamics Investment Count  & Drastically Decrease Training Time by Providing Intuitive Step-By-Step WalkThru Tutorials.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Lately there has been a variety of news related to U.S. employment.  Stories about worker productivity, automobile and airline unions, low employment and foreign laborers have frequented the news.  Each story has good and bad attributes we might arg…
A high-level exploration of how our ever-increasing access to information has changed the way we do our jobs.
This video walks the viewer through the process of creating a watermark for their document, customizing it, and saving it for viewing/printing needs.
The viewer will learn how to make their project stand out over others by learning how to change colors and shapes, add spaces, change directions, and add bullets to their charts.

734 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question