VBA Color duplicates with different colors in a table

[floggingmolly]

I have a VBA code that colors duplicates with different colors. This works, but when I convert the range to a table it no longer works. Can anyone assist with adjusting this code to work with a table? Any help would be greatly appreciated.

Sub ColorDupsRGB()
  Dim a As Variant, ky As Variant
  Dim dic As Object, r As Range, i As Long, nColor As String
  Application.ScreenUpdating = False
 
  Set r = Range("A3:H" & Range("A" & Rows.Count).End(xlUp).Row)
  r.Interior.ColorIndex = xlNone
  a = Application.Index(r.Value2, , 1)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
 
  nColor = 300000000
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      r.Offset(-1).AutoFilter 1, ky
      ActiveSheet.AutoFilter.Range.Offset(1).Interior.Color = nColor
      nColor = nColor + 1000000
    End If
  Next
  If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
  r.Offset(r.Rows.Count).Resize(1).Interior.Color = xlNone
End Sub

 

[DanteAmor]

it no longer works

What doesn't work?
Does the code generate an error?
What does the error message say?
If you press debug, at what line does the macro stop?

I have tested the macro on a table and it works.
I only changed this line:

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

For this:

Range("A2").AutoFilter

 

[floggingmolly]

What doesn't work?
Does the code generate an error?
What does the error message say?
If you press debug, at what line does the macro stop?

I have tested the macro on a table and it works.
I only changed this line:

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

For this:

Range("A2").AutoFilter

The error says Object Variable or With block variable not set

 

[DanteAmor]

If you press debug, at what line does the macro stop?

?

 

[floggingmolly]

Debug doesn't do anything. When I run the code with just a range, A:H1000 it colors each set of duplicates in a different color. When I make A:H1000 a table, I get that message I mentioned above and then the table is filtered so only the duplicates are showing but the rows are not colored. I have no clue?

 

[floggingmolly]

?

Here is the line highlighted when I click Debug r.Offset(-1).AutoFilter 1, ky

Then the next time this line is highlighted ActiveSheet.AutoFilter.Range.Offset(1).Interior.Color = nColor

 

[DanteAmor]

I think the problem is because you have empty rows in the table.
Try the version of the code for a table.

Adjust the name of your table in the code.

Sub ColorDupsRGB()
  Dim a As Variant, ky As Variant
  Dim dic As Object, r As Range, i As Long, nColor As String
  Dim tbl As ListObject
  
  Application.ScreenUpdating = False
 
  Set tbl = ActiveSheet.ListObjects("Table1") 'Fit your table name
  tbl.Range.AutoFilter
  Set r = tbl.DataBodyRange
  r.Interior.ColorIndex = xlNone
  a = Application.Index(r.Value2, , 1)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
 
  nColor = 300000000
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      tbl.Range.AutoFilter 1, ky
      tbl.Range.Offset(1).Interior.Color = nColor
      nColor = nColor + 1000000
    End If
  Next
  tbl.Range.AutoFilter
  tbl.Range.AutoFilter
  r.Offset(r.Rows.Count).Resize(1).Interior.Color = xlNone
End Sub

 

[floggingmolly]

I think the problem is because you have empty rows in the table.
Try the version of the code for a table.

Adjust the name of your table in the code.

Sub ColorDupsRGB()
  Dim a As Variant, ky As Variant
  Dim dic As Object, r As Range, i As Long, nColor As String
  Dim tbl As ListObject
 
  Application.ScreenUpdating = False
 
  Set tbl = ActiveSheet.ListObjects("Table1") 'Fit your table name
  tbl.Range.AutoFilter
  Set r = tbl.DataBodyRange
  r.Interior.ColorIndex = xlNone
  a = Application.Index(r.Value2, , 1)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
 
  nColor = 300000000
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      tbl.Range.AutoFilter 1, ky
      tbl.Range.Offset(1).Interior.Color = nColor
      nColor = nColor + 1000000
    End If
  Next
  tbl.Range.AutoFilter
  tbl.Range.AutoFilter
  r.Offset(r.Rows.Count).Resize(1).Interior.Color = xlNone
End Sub

I just got a chance to try this and it worked. Thank you so much. I really appreciate you taking the time to help. Have a great day.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback. Also have a nice day

 

[sofas]

Hello, I tried to modify the code to be able to implement it without creating a table, but I could not. My repeating column is b and I want to color the row from column b to f provided the same value is repeated in column b and each section with a specific color

I think the problem is because you have empty rows in the table.
Try the version of the code for a table.

Adjust the name of your table in the code.

Sub ColorDupsRGB()
  Dim a As Variant, ky As Variant
  Dim dic As Object, r As Range, i As Long, nColor As String
  Dim tbl As ListObject
 
  Application.ScreenUpdating = False
 
  Set tbl = ActiveSheet.ListObjects("Table1") 'Fit your table name
  tbl.Range.AutoFilter
  Set r = tbl.DataBodyRange
  r.Interior.ColorIndex = xlNone
  a = Application.Index(r.Value2, , 1)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
 
  nColor = 300000000
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      tbl.Range.AutoFilter 1, ky
      tbl.Range.Offset(1).Interior.Color = nColor
      nColor = nColor + 1000000
    End If
  Next
  tbl.Range.AutoFilter
  tbl.Range.AutoFilter
  r.Offset(r.Rows.Count).Resize(1).Interior.Color = xlNone
End Sub

Sub ColorDupsRGB()
  Dim a As Variant, ky As Variant
  Dim dic As Object, r As Range, i As Long, nColor As String
  Dim tbl As ListObject
  Dim MH As Variant
  Dim Idx As Long
 
  Application.ScreenUpdating = False
 
  Set tbl = ActiveSheet.ListObjects("Table1") 'Fit your table name
  tbl.Range.AutoFilter
  Set r = tbl.DataBodyRange
  r.Interior.ColorIndex = xlNone
  a = Application.Index(r.Value2, , 1)
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
 
   MH = Array(RGB(204, 255, 255), RGB(51, 204, 204), RGB(204, 204, 204), _
RGB(153, 204, 0), RGB(255, 102, 0), RGB(255, 128, 128), _
 RGB(204, 204, 155), RGB(255, 255, 0), RGB(255, 153, 0), RGB(0, 255, 0), RGB(255, 0, 255))

  For Each ky In dic.keys
    If dic(ky) > 1 Then
      tbl.Range.AutoFilter 1, ky
      tbl.Range.Offset(1).Interior.Color = MH(Idx)
      Idx = Idx + 1
    End If
  Next
  tbl.Range.AutoFilter
  tbl.Range.AutoFilter
  r.Offset(r.Rows.Count).Resize(1).Interior.Color = xlNone
End Sub