Making Rule work on Select Columns

[shba]

Hey I have this rule which highlights duplicates in a row in different colors so if you have a row that is

1
1
1
2
2
3
1
3

All the one's will be blue 2's red and 1's white. Currently the rule below only works on column A. All my columns have headers, and I need it to instead of working on column A work on the columns with header names I choose.
Anyone have any idea how this can be accomplished??

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range
Dim K
Dim col
Dim c As Integer
If Target.Column = 1 Then
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
End If
Next
col = Array(3, 50, 6, 7, 8, 34, 35, 38, 39, 50, 45, 46)
For Each K In .keys
If .Item(K).Count > 1 Then
c = IIf(c = 12, 0, c)
.Item(K).Interior.ColorIndex = col(c)
c = c + 1
End If
Next K
End With
End If
End Sub

[shba]

Anyone have an idea?

[tigeravatar]

shba,

Welcome to the forum! In the future, please wrap your code in code tags (see link in my sig for how).
As for your question, you need to change the If Target.Column = 1 line. So if you wanted the code to monitor columns A, C and K (which are column numbers 1, 3, and 11) the line would look like this:

If InStr(1, " " & Target.Column & " ", " 1 3 11 ", vbTextCompare) > 0 Then

[tigeravatar]

shba,

I received your PM which contained the following:

shba,

Welcome to the forum! In the future, please wrap your code in code tags (see link in my sig for how).
As for your question, you need to change the If Target.Column = 1 line. So if you wanted the code to monitor columns A, C and K (which are column numbers 1, 3, and 11) the line would look like this:

If InStr(1, " " & Target.Column & " ", " 1 3 11 ", vbTextCompare) > 0 Then

Hey thank you for the reply, but this isn't my question. I need this rule to work on many different files A, C and K won't always be the correct columns I need the rule to work on the column with the name IP but that column will sometimes be column A other times C and so forth.

Thanks
Yair

Ugly part first, from the forum rules:
4. Don't Private Message or email Excel questions to moderators or other members. (or Word, Access, etc.) The point of having a public forum is to share solutions to common (and sometimes uncommon) problems with all members.


Alright, on to your question. So basically the Target.Column needs to be dynamic. You can accomplish this using the Range.Find method like so:

    Dim rngFound As Range
    
    Set rngFound = Target.Parent.Rows(1).Find("IP", , xlValues, xlWhole)
    If rngFound Is Nothing Then Exit Sub
    If Target.Column = rngFound.Column Then

[shba]

    Dim rngFound As Range
    
    Set rngFound = Target.Parent.Rows(1).Find("IP", , xlValues, xlWhole)
    If rngFound Is Nothing Then Exit Sub
    If Target.Column = rngFound.Column Then

Thank you, I think this is exactly what I needed, I'm having trouble combining them, adding the code instead of

If Target.Column = 1 Then

I also tried replacing it with

Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

but I get an error in this part of the code

For Each Dn In Rng

[tigeravatar]

shba,

Thank you for using code tags
I think the full code would look like this:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Rng As Range, Dn As Range, rngFound As Range
    Dim K
    Dim col
    Dim c As Integer
    
    Set rngFound = Target.Parent.Rows(1).Find("IP", , xlValues, xlWhole)
    If rngFound Is Nothing Then Exit Sub
    If Target.Column = rngFound.Column Then
        Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        With CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
            For Each Dn In Rng
                If Not .Exists(Dn.Value) Then
                    .Add Dn.Value, Dn
                Else
                    Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
                End If
            Next
            col = Array(3, 50, 6, 7, 8, 34, 35, 38, 39, 50, 45, 46)
            For Each K In .keys
                If .Item(K).Count > 1 Then
                    c = IIf(c = 12, 0, c)
                    .Item(K).Interior.ColorIndex = col(c)
                    c = c + 1
                End If
            Next K
        End With
    End If
    
End Sub

[shba]

Thanks, It's kind of working, now it will work on column A and if the column header is IP. I've tried changing the Range, but I keep getting errors no matter how I change it , I need it to work on the entire document.

Also If i want to add another name which will work just add something after the IP? so for example

Set rngFound = Target.Parent.Rows(1).Find("IP","ID","NAME" , xlValues, xlWhole)

[shba]

Anyone have an idea?

[tigeravatar]

shba,

Updated code, should address both issues:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Rng As Range, Dn As Range, rngFound As Range
    Dim K
    Dim col
    Dim c As Integer
    Dim varFind As Variant
    
    For Each varFind In Array("IP", "ID", "NAME")
        Set rngFound = Target.Parent.Rows(1).Find(varFind, , xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            If Target.Column = rngFound.Column Then
                Set Rng = Range(Cells(1, Target.Column), Cells(Rows.Count, Target.Column).End(xlUp))
                With CreateObject("scripting.dictionary")
                    .CompareMode = vbTextCompare
                    For Each Dn In Rng
                        If Not .Exists(Dn.Value) Then
                            .Add Dn.Value, Dn
                        Else
                            Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
                        End If
                    Next
                    col = Array(3, 50, 6, 7, 8, 34, 35, 38, 39, 50, 45, 46)
                    For Each K In .keys
                        If .Item(K).Count > 1 Then
                            c = IIf(c = 12, 0, c)
                            .Item(K).Interior.ColorIndex = col(c)
                            c = c + 1
                        End If
                    Next K
                End With
            End If
        End If
    Next varFind
    
End Sub

[shba]

Works great thank you very much for all your help.