Code To Find Duplicates And Highlight

[Dazzawm]

Is there a code or formula for when there is matching cells in column C that will then look in column AE and highlight any duplicate values please?

 

[Akuini]

Could be anything up to about 150, 000 rows.

Well, please try it on a small sample first. It it works then try it on your actual data. If it takes too long, we'll try to amend the code to work faster.

 

[Dazzawm]

About how many rows is your data in col C?
Another option to try:

Sub Dazzawm_1()
'' section group looping
Dim i As Long, j As Long, n As Long
Dim c As Range, a
Dim t As Double
t = Timer - t
Range("C:C").Interior.Color = xlNone
n = Range("C" & Rows.Count).End(xlUp).Row

For i = 2 To n
    If Len(Cells(i, "C")) > 0 Then
        j = WorksheetFunction.CountIf(Range("C" & i & ":C" & n), Cells(i, "C")) 'case insensitive
'            Debug.Print Cells(i, "A").Resize(j).Address
            a = WorksheetFunction.Unique(Cells(i, "AE").Resize(j))
            If UBound(a) < j Then
                If c Is Nothing Then
                    Set c = Cells(i, "C").Resize(j)
                Else
                    Set c = Union(c, Cells(i, "C").Resize(j))
                End If
            End If
            i = i + j - 1
    End If
Next
c.Interior.Color = vbYellow
Debug.Print "It's done in:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

Book1
	B	C	D																										AD	AE	AF
1
2		G																												a
3		G																												b
4		J																												a
5		K																												b
6		M																												a
7		M																												a
8		M																												b
9		S																												a
10		S																												b
11		S																												c
12		U																												a
13		U																												b
14		U																												a
15
Sheet1

Very odd, I got this error

And when I debug it points to

c.Interior.Color = vbYellow

 

[Akuini]

Very odd, I got this error

And when I debug it points to

c.Interior.Color = vbYellow

If you try it on a small sample, make sure there are duplicates in col AE.

 

[Dazzawm]

If you try it on a small sample, make sure there are duplicates in col AE.

It appears to bring up that error when there are no duplicates in AE. Any chance the whole row could be coloured, not just C please?

 

[Akuini]

It appears to bring up that error when there are no duplicates in AE. Any chance the whole row could be coloured, not just C please?

Just change:
c.Interior.Color = vbYellow
to:
c.EntireRow.Interior.Color = vbYellow

I tested the code with 150K rows of data, and it took 224 seconds. If this is a one-time task, then that should be sufficient. However, if this is a recurring task, I can attempt to modify the code.

 

[Dazzawm]

Just change:
c.Interior.Color = vbYellow
to:
c.EntireRow.Interior.Color = vbYellow

I tested the code with 150K rows of data, and it took 224 seconds. If this is a one-time task, then that should be sufficient. However, if this is a recurring task, I can attempt to modify the code.

I will be using it on multiple files of varying sizes so up to you. Instead of that error coming up could a message box pop up saying no duplicates found in AE, something like that please?

 

[Legacy 143009]

Please find the working sample:

https://file.io/MI7fgFuDikWB

I also altered the code a bit:

Sub test()
  Dim d As Object, columnC As Variant, columnAE As Variant, i As Long, j As Long, counter As Long, s As Long
  Set d = CreateObject("Scripting.Dictionary")
  With Application
  columnC = .Transpose(Intersect(UsedRange, Columns("C")))
  columnAE = .Transpose(Intersect(UsedRange, Columns("AE")))
  .ScreenUpdating = False
 
  For i = 2 To UBound(columnC)
    If columnC(i) = columnC(i - 1) Then
      d.Add columnAE(i - 1), 1
      If d.Exists(columnAE(i)) Then
      counter = 0
        For j = s To UBound(columnC)
          If columnC(s) = columnC(j) Then
            counter = counter + 1
          Else
            Exit For
          End If
        Next
        Cells(s, 3).Resize(counter).Interior.Color = 65535
        d.RemoveAll
        i = j
        s = i
      End If
    Else
      s = i
      d.RemoveAll
    End If
  Next

  .ScreenUpdating = True
  End With
End Sub

 

[Akuini]

I will be using it on multiple files of varying sizes so up to you. Instead of that error coming up could a message box pop up saying no duplicates found in AE, something like that please?

Have you tried it on your actual data? How long did it take?
Try this one to pop up a message when there's no duplicate:

Sub Dazzawm_2()
'' section group looping
Dim i As Long, j As Long, n As Long
Dim c As Range, a
Dim t As Double
t = Timer - t
Range("C:C").Interior.Color = xlNone
n = Range("C" & Rows.Count).End(xlUp).Row

For i = 2 To n
    If Len(Cells(i, "C")) > 0 Then
        j = WorksheetFunction.CountIf(Range("C" & i & ":C" & n), Cells(i, "C")) 'case insensitive
'            Debug.Print Cells(i, "A").Resize(j).Address
            a = WorksheetFunction.Unique(Cells(i, "AE").Resize(j))
            If UBound(a) < j Then
                If c Is Nothing Then
                    Set c = Cells(i, "C").Resize(j)
                Else
                    Set c = Union(c, Cells(i, "C").Resize(j))
                End If
            End If
            i = i + j - 1
    End If
Next

If Not c Is Nothing Then
    c.EntireRow.Interior.Color = vbYellow
Else
    MsgBox "No duplicates found"
End If
Debug.Print "It's done in:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

 

[Dazzawm]

Please find the working sample:

https://file.io/MI7fgFuDikWB

I also altered the code a bit:

Sub test()
  Dim d As Object, columnC As Variant, columnAE As Variant, i As Long, j As Long, counter As Long, s As Long
  Set d = CreateObject("Scripting.Dictionary")
  With Application
  columnC = .Transpose(Intersect(UsedRange, Columns("C")))
  columnAE = .Transpose(Intersect(UsedRange, Columns("AE")))
  .ScreenUpdating = False
 
  For i = 2 To UBound(columnC)
    If columnC(i) = columnC(i - 1) Then
      d.Add columnAE(i - 1), 1
      If d.Exists(columnAE(i)) Then
      counter = 0
        For j = s To UBound(columnC)
          If columnC(s) = columnC(j) Then
            counter = counter + 1
          Else
            Exit For
          End If
        Next
        Cells(s, 3).Resize(counter).Interior.Color = 65535
        d.RemoveAll
        i = j
        s = i
      End If
    Else
      s = i
      d.RemoveAll
    End If
  Next

  .ScreenUpdating = True
  End With
End Sub

Still the same error

 

[Dazzawm]

Have you tried it on your actual data? How long did it take?
Try this one to pop up a message when there's no duplicate:

Sub Dazzawm_2()
'' section group looping
Dim i As Long, j As Long, n As Long
Dim c As Range, a
Dim t As Double
t = Timer - t
Range("C:C").Interior.Color = xlNone
n = Range("C" & Rows.Count).End(xlUp).Row

For i = 2 To n
    If Len(Cells(i, "C")) > 0 Then
        j = WorksheetFunction.CountIf(Range("C" & i & ":C" & n), Cells(i, "C")) 'case insensitive
'            Debug.Print Cells(i, "A").Resize(j).Address
            a = WorksheetFunction.Unique(Cells(i, "AE").Resize(j))
            If UBound(a) < j Then
                If c Is Nothing Then
                    Set c = Cells(i, "C").Resize(j)
                Else
                    Set c = Union(c, Cells(i, "C").Resize(j))
                End If
            End If
            i = i + j - 1
    End If
Next

If Not c Is Nothing Then
    c.EntireRow.Interior.Color = vbYellow
Else
    MsgBox "No duplicates found"
End If
Debug.Print "It's done in:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

That seemed to work fine on a small file.