Macro to fill up pre defined colors for duplicates in single column

IKHAN · Mar 15, 2016

Hello

Found below macro to find duplicates in single column and highlight matching values, Issue with this macro is it uses only 1 color (red) and searches for duplicates in other columns

Require below pre defined colors to be added in below macro and search for duplicates in only single column.Fil up color based on change event.

Color= 4
color=7
Color= 12
color=38
color=39
color= 40
color=46

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim Rng As Range
  Dim cel As Range
  Dim col As Range
  Dim c As Range
  Dim firstAddress As String


  Target.Interior.ColorIndex = xlNone
  For Each col In Target.Columns
  Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
  Debug.Print Rng.Address

  For Each cel In col
  If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
  Set c = Rng.Find(What:=cel.Value, LookIn:=xlValues)
  If Not c Is Nothing Then
  firstAddress = c.Address
  Do
  c.Interior.ColorIndex = 3
  Set c = Rng.FindNext(c)
  Loop While Not c Is Nothing And c.Address <> firstAddress
  End If
  End If
  Next
  Next col

End Sub

Nebu · Mar 15, 2016

Hi:

Find the attached.

Thanks

IKHAN · Mar 16, 2016

Nebu said:
Hi:

Find the attached.

Thanks

Thanks for quick reply..

Help me modify
1.My Original data is in column D and sheet named "Plan"(Sheet 3)
2. Only predefined Colors to be used provided in list and option to add more colors if reqd.
3. In your macro - Colors change on new entry for previous entries.
4. When reqd. - It's better option for us to clear any color (no fill) for any cell.

IKHAN · Mar 16, 2016

Any help Please ??

My orIginal data in column D has dates/times to compare in format (ddd mmm dd,yyyy - hh:mm AM/PM - please see my previous post

Nebu · Mar 17, 2016

Hi:

I am afraid I understood you fully. As far as the Column and sheet name is concerned change the range and sheet name in the code. I am not sure about predefined color, you mean to say that for each item in your list you have predefined a color? if you are not familiar with VBA you may have to upload an exact replica of your original file here.

Thanks

IKHAN · Mar 17, 2016

Nebu said:
Hi:

I am afraid I understood you fully. As far as the Column and sheet name is concerned change the range and sheet name in the code. I am not sure about predefined color, you mean to say that for each item in your list you have predefined a color? if you are not familiar with VBA you may have to upload an exact replica of your original file here.

Thanks

Hi : Have uploaded modified original file.

Macro provided doesn't work for dates/times in column D.

Really appreciate your help!!!

Nebu · Mar 18, 2016

Hi:

Find the attached.

Thanks

IKHAN · Apr 7, 2016

@Nebu ...Dates and times are very often changed, Your solution doesn' if date or time is changed and new dups found

jindon · Apr 7, 2016

Try

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range, myColor, n As Long
    If Intersect(Target, Columns("a")) Is Nothing Then Exit Sub
    myColor = Array(4, 7, 12, 38, 39, 40, 46)
    Columns(1).Interior.ColorIndex = xlNone
    ReDim Preserve myColor(1 To UBound(myColor) + 1)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
            If r.Value <> "" Then
                If Not .exists(r.Value) Then
                    Set .Item(r.Value) = r
                Else
                    If TypeOf .Item(r.Value) Is Range Then
                        n = n + 1: If n > UBound(myColor) Then n = 1
                        Union(.Item(r.Value), r).Interior.ColorIndex = myColor(n)
                        .Item(r.Value) = myColor(n)
                    Else
                        r.Interior.ColorIndex = .Item(r.Value)
                    End If
                End If
            End If
        Next
    End With
End Sub

IKHAN · Apr 10, 2016

@Nebu ..Have another worksheet change macro running in same tab, How do i combine both to run. please see attached

Macro currently running below:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then

Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If oldVal = "" Then

Else
If newVal = "" Then

Else
Target.Value = oldVal & "; " & newVal

End If
End If
End If

exitHandler:
Application.EnableEvents = True
End Sub

IKHAN · Apr 10, 2016

Oops meant @jindon ..msg above

jindon · Apr 10, 2016

The code I wrote should be in "4. Mobile" sheet, not the one you have Change event code, so should be OK.

IKHAN · Apr 10, 2016

jindon said:
The code I wrote should be in "4. Mobile" sheet, not the one you have Change event code, so should be OK.

@jindon Code is in 4 .mobile as suggested, It doesn't work...see attached.

jindon · Apr 11, 2016

Ok then try replace the whole code with the following

Code:

Private Sub Worksheet_Activate()
    Dim r As Range, a, i As Long, e, x
    Application.EnableEvents = False
    With Sheets("2. Planning")
        If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
            a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        x = Split(Application.Trim(e))
                        ReDim Preserve x(1)
                        .Item(Trim$(e)) = x
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
    Application.EnableEvents = True
    Worksheet_Change Range("d17")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range, myColor, n As Long
    If Intersect(Target, Columns("D")) Is Nothing Then Exit Sub
    [d17].CurrentRegion.Columns(1).Offset(1).Interior.ColorIndex = xlNone
    myColor = Array(4, 7, 12, 38, 39, 40, 46)
    Columns(1).Interior.ColorIndex = xlNone
    ReDim Preserve myColor(1 To UBound(myColor) + 1)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each r In Range("D13", Range("D" & Rows.Count).End(xlUp))
            If r.Value <> "" Then
                If Not .exists(r.Value) Then
                    Set .Item(r.Value) = r
                Else
                    If TypeOf .Item(r.Value) Is Range Then
                        n = n + 1: If n > UBound(myColor) Then n = 1
                        Union(.Item(r.Value), r).Interior.ColorIndex = myColor(n)
                        .Item(r.Value) = myColor(n)
                    Else
                        r.Interior.ColorIndex = .Item(r.Value)
                    End If
                End If
            End If
        Next
    End With
End Sub

IKHAN · Apr 11, 2016

@ Jindon ..Was able to run earlier code provided successfully...I have few rows Highlighted row 1 to row 3 and when code executed ..it clears highlights in column D.

1. Can i maintain those highlighted rows ( row1 to row 3)?
2.Have same info in another tab in column D,can his be highlighted too for any dups as any changes done?

IKHAN · Apr 11, 2016

jindon said:

Ok then try replace the whole code with the following

Code:

Private Sub Worksheet_Activate()
    Dim r As Range, a, i As Long, e, x
    Application.EnableEvents = False
    With Sheets("2. Planning")
        If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
            a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        x = Split(Application.Trim(e))
                        ReDim Preserve x(1)
                        .Item(Trim$(e)) = x
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
    Application.EnableEvents = True
    Worksheet_Change Range("d17")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range, myColor, n As Long
    If Intersect(Target, Columns("D")) Is Nothing Then Exit Sub
    [d17].CurrentRegion.Columns(1).Offset(1).Interior.ColorIndex = xlNone
    myColor = Array(4, 7, 12, 38, 39, 40, 46)
    Columns(1).Interior.ColorIndex = xlNone
    ReDim Preserve myColor(1 To UBound(myColor) + 1)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each r In Range("D13", Range("D" & Rows.Count).End(xlUp))
            If r.Value <> "" Then
                If Not .exists(r.Value) Then
                    Set .Item(r.Value) = r
                Else
                    If TypeOf .Item(r.Value) Is Range Then
                        n = n + 1: If n > UBound(myColor) Then n = 1
                        Union(.Item(r.Value), r).Interior.ColorIndex = myColor(n)
                        .Item(r.Value) = myColor(n)
                    Else
                        r.Interior.ColorIndex = .Item(r.Value)
                    End If
                End If
            End If
        Next
    End With
End Sub

Uploaded file

Please see tab 2 , 3 ,4

To highlight dups in column D from line 13 in sheet 2 and sheet 3 column D

IKHAN · Apr 11, 2016

oops forgot to include testfile

jindon · Apr 12, 2016

I'm totally lost...

Are you entering any data in col D of "4. Mobile" manually or via other sub routine?

If not, it should always have unique values?

IKHAN · Apr 12, 2016

jindon said:
I'm totally lost...

Are you entering any data in col D of "4. Mobile" manually or via other sub routine?

If not, it should always have unique values?

Entering data in "2. planning" in column D manually and also through formula

Column D = (=D13 or D14 or D15)

and also noticed that when duration changes in Column F and date\time changes ,it doesn't reevaluate column D and highlight duplicate accordingly.

See attached sample test file

IKHAN · Apr 14, 2016

Guys.. Any suggestion.. Above code is almost there.just need minor tweaks.

Any change in column d ( enter new data, change thru another cell)in planning tab should re evaluate col D and update fill colours for dups in column d

Macro to fill up pre defined colors for duplicates in single column

Member

Attachments

Excel Ninja

Attachments

Member

Member

Excel Ninja

Member

Attachments

Excel Ninja

Attachments

Member

Well-Known Member

Attachments

Member

Attachments

Member

Well-Known Member

Member

Attachments

Well-Known Member

Member

Member

Member

Attachments

Well-Known Member

Member

Attachments

Member