VBA Color duplicates with different colors

[msmonster]

I'm having a difficult time trying to adjust the code in VBA to find the duplicate ID numbers between two separate columns (A, B). There is over 17,000 lines in column B and 7700 lines in column A. Currently, the code is able to find the duplicates in a single column (B). The basic conditional format will not work in this scenario due to it only highlighting all duplicate versus matching individual duplicates.


Example Sheet:

External ID ID
900222111 900333222
900111222 900222111
900333222 900111222


Sub ColorDupsRGB()
Dim a As Variant, ky As Variant
Dim dic As Object, r As Range, i As Long, nColor As Long
Application.ScreenUpdating = False
Set r = Range("A3:T" & Range("B" & Rows.Count).End(xlUp).Row)
r.Interior.ColorIndex = xlNone
a = Application.Index(r.Value2, , 2)
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 2, 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]

If you want a result like this:

Try the following:

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