CODEWITHSUNDEEP
excelvba
Bgs14
Bgs14

Reputation: 23

Excel VBA Highlight duplicates in active column

I'm trying to create a macro that will highlight duplicates in the column where text is being entered.

I have 54 columns and want to highlight duplicates in each column as the text is entered. The scenario is: if "STAPLES" is entered twice in column B then the cells (B3, B22) would be highlighted. I want a macro that can do this for each column, so if "STAPLES" is entered into column E only once nothing should happen.

Using the Conditional Formatting =COUNTIF doesn't necessarily help (due to the workflow of copying columns to new worksheets).

I have this macro already:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


Dim Rng As Range
Dim cel As Range

'Test for duplicates in a single column
'Duplicates will be highlighted in red


Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))


For Each cel In Rng
    If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then

cel.Interior.ColorIndex = 3
    End If
Next cel

End Sub

It works ok but is only for one column ("C").

How do I set the range to be the active column?

I have tried to change Rng to 

'Set Rng = Range(ActiveCell,ActiveCell.Column.End(xlUp))

but this is obviously wrong.

Any ideas?

Upvotes: 2

Views: 32602

Answers (1)

Dmitry Pavliv
Dmitry Pavliv

Reputation: 35863

Try this one:

Set Rng = Range(Cells(1, Target.Column), Cells(Rows.Count, Target.Column).End(xlUp))

and it's better to use Worksheet_Change event instead Worksheet_SelectionChange.

Btw, there is special CF for duplicates:

enter image description here

UPD: If you'd like to use VBA, try following 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



    'Duplicates will be highlighted in red
    Target.Interior.ColorIndex = xlNone
    For Each col In Target.Columns
        Set Rng = Range(Cells(1, col.Column), Cells(Rows.Count, col.Column).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

Upvotes: 5

Related Questions