Highlight Rows of Duplicate results column with unique coloring

**scottiex** · 07-20-2017, 07:06 PM

How would this be useful?

regardless try this.

Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20160704
' with changes for excelforum 20170721
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Range("F2:F1289")
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection
    For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
      xCIndex = xCIndex + 1
        xCell.EntireRow.Interior.ColorIndex = xCIndex
        Else
        xCIndex = 2
      End If
      On Error GoTo 0
    Next
End Sub

**G-Co** · 07-21-2017, 02:17 PM

Originally Posted by scottiex

How would this be useful?

regardless try this.

...
End Sub[/CODE]

Scottiex, thanks for the attempt but it resulted in the last record in a group being highlighted, and after about 20 lines every line was highlighted irrespective of duplicate values.
To answer your question, this is useful as we are merging two data sets from different MCOs which share services and part numbers. We need to easily identify where a service and part number repeated for audit purposes.

This morning I found the following script which is very close to what I want but it is looking duplicates in column A not F. I'm not sure how to alter it in this regard.

Sub HighlightUniqueDuplicatesGC()
Dim sh As Worksheet, c As Range, clr As Variant, lr As Long
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
clr = Array(3, 4, 6, 7, 8, 10, 12, 13, 14, 15, 16, 17, 18, 19, 20, 22, 23, 24, 26, 27, 28, 31, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 50, 53, 54)
With sh
.Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , .Range("B" & lr + 2), True
x = LBound(clr)
For Each c In .Range("B" & lr + 4).CurrentRegion
.UsedRange.AutoFilter 1, c.Value
If Application.CountIf(.Range("A:A"), c.Value) > 1 Then
.Range("A2", .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = clr(x)
End If
.AutoFilterMode = False
x = x + 1
If x > UBound(clr) Then x = LBound(clr)
Next
.Range("B" & lr + 2).CurrentRegion.Delete
End With
End Sub

**scottiex** · 07-23-2017, 04:59 PM

OK seems I misunderstood your requirement.

messy coding but here is a quick fix that seems to work... I see they limited the colours presumably to retain contrast.

Sub HighlightUniqueDuplicatesGC()
Dim sh As Worksheet, c As Range, clr As Variant, lr As Long
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
clr = Array(3, 4, 6, 7, 8, 10, 12, 13, 14, 15, 16, 17, 18, 19, 20, 22, 23, 24, 26, 27, 28, 31, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 50, 53, 54)
With sh
.Range("F1:F" & lr).AdvancedFilter xlFilterCopy, , .Range("EE" & lr + 2), True
x = LBound(clr)
For Each c In .Range("EE" & lr + 4).CurrentRegion
.UsedRange.AutoFilter 1, c.Value
If Application.CountIf(.Range("F:F"), c.Value) > 1 Then
.Range("F2", .Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = clr(x)
End If
.AutoFilterMode = False
x = x + 1
If x > UBound(clr) Then x = LBound(clr)
Next
.Range("EE" & lr + 2).CurrentRegion.Delete
End With
End Sub

"To answer your question, this is useful as we are merging two data sets from different MCOs which share services and part numbers. We need to easily identify where a service and part number repeated for audit purposes."

I see why they would ask for that, I sometimes get asked for that sort of thing. But there should be a better way. I presume once they find a duplicate they take some action and I imagine having a helper column with some indicator of what to do would be more useful.

**G-Co** · 07-24-2017, 12:59 PM

Originally Posted by scottiex

OK seems I misunderstood your requirement.

messy coding but here is a quick fix that seems to work... I see they limited the colours presumably to retain contrast.

Sub HighlightUniqueDuplicatesGC()
Dim sh As Worksheet, c As Range, clr As Variant, lr As Long
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
clr = Array(3, 4, 6, 7, 8, 10, 12, 13, 14, 15, 16, 17, 18, 19, 20, 22, 23, 24, 26, 27, 28, 31, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 50, 53, 54)
With sh
.Range("F1:F" & lr).AdvancedFilter xlFilterCopy, , .Range("EE" & lr + 2), True
x = LBound(clr)
For Each c In .Range("EE" & lr + 4).CurrentRegion
.UsedRange.AutoFilter 1, c.Value
If Application.CountIf(.Range("F:F"), c.Value) > 1 Then
.Range("F2", .Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = clr(x)
End If
.AutoFilterMode = False
x = x + 1
If x > UBound(clr) Then x = LBound(clr)
Next
.Range("EE" & lr + 2).CurrentRegion.Delete
End With
End Sub

"To answer your question, this is useful as we are merging two data sets from different MCOs which share services and part numbers. We need to easily identify where a service and part number repeated for audit purposes."

I see why they would ask for that, I sometimes get asked for that sort of thing. But there should be a better way. I presume once they find a duplicate they take some action and I imagine having a helper column with some indicator of what to do would be more useful.

Thanks for the followup Scottiex.
I ran the new code but it yielded a runtime error. I tried pre-selecting (highlighting) the range before running the code as well, to see if that would limit but same error.
I am attaching an excerpt of sample data which I have manually highlighted lines to what I am hoping the end result would be (again, based on column F being duplicate. more obvious in the last records).
Thanks again.