Solved

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

Posted on 2014-10-18
20
596 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
  • 12
  • 8
20 Comments
 
LVL 45

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 45

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
 

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 45

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 45

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 45

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 45

Expert Comment

by:Martin Liss
ID: 40392595
This is tough but I'm getting there.
0
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 
LVL 45

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 45

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 45

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 45

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 45

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 45

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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

I recently resolved a client's Office 2013 installation problem and wanted to offer an observation that may help you with troubleshooting similar issues. The client ordered three Dell Optiplex system units with the Windows 7 downgrade option inst…
This article describes how to use the Send to Mail Recipient command. The instructions apply generally to Office 2007 and later versions, but Microsoft® Word 2013 was used for the specific steps and figures.  What is Send to Mail Recipient? Send…
This video teaches the viewer how to align pictures around text while keeping the text properly aligned in the document.
This video walks the viewer through the process of creating an MLA formatted document, as well as a bibliography with citations.

706 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now