VBA Highlight duplicates between two ranges

[Yamasaki450]

Hello everyone... I need some help again.

I need VBA code to highlight all duplicate numbers red between two ranges in each column separately. And then highlight all numbers blue according
to last duplicate number in that column. I made this manually for the first column to show this more clearly. See screenshot.
I also need to be able to adjust the ranges in VBA code... they are not always the same.

Does anyone have time and skill to write VBA code for this?

As always.
Thank you guys...

 

[Georgiboy]

You're welcome, thanks for the feedback.

 

[Peter_SSs]

Both codes work but the one that Georgiboy posted is much faster when it comes to larger amount of data.

That's interesting, especially the "much" part. For the data in your sample file, on my machine my code is slightly faster (& I do have a little correction that should make it marginally faster).
The relative speed though would depend somewhat on how many matches are found in each column.
For interest, wondering if you could provide a link to a sample file with a "larger amount of data" so that I can test/experiment a little further?

 

[Yamasaki450]

That's interesting, especially the "much" part. For the data in your sample file, on my machine my code is slightly faster (& I do have a little correction that should make it marginally faster).
The relative speed though would depend somewhat on how many matches are found in each column.
For interest, wondering if you could provide a link to a sample file with a "larger amount of data" so that I can test/experiment a little further?

Sure. Here it is.

Loading Google Sheets

 

[fahad_ibnfurjan]

Thanks for the reply, and also thanks to Peter for correcting my mistake with his contribution.

Sub AppltFrmt()

Call Set_Format_Conditions("B2:K24", "B$29:K$40")

End Sub
Sub Set_Format_Conditions(FrmtRng As String, CartraRng As String)
Dim Rng As Range
    With Range(FrmtRng)
        FrmtRngCll = .Cells(1, 1).Address(0, 0)
        FrmtRngCol1 = .Columns(1).Address(1, 0)
        CartraRng = Range(CartraRng).Columns(1).Address(1, 0)
        
        .FormatConditions.Delete
        .Interior.Pattern = xlNone
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=IFNA(MATCH(" & FrmtRngCll & "," & CartraRng & ",0),0)*COUNTIF(" & FrmtRngCol1 & "," & FrmtRngCll & ")<>0"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 592383
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
        
        
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=" & FrmtRngCll & "=INDEX(" & FrmtRngCol1 & ",MAX(IFERROR(ROW(INDIRECT(""1:""&ROWS(" & FrmtRngCol1 & ")))/(IFNA(MATCH(" & FrmtRngCol1 & "," & CartraRng & ",0),0)*COUNTIF(" & FrmtRngCol1 & "," & FrmtRngCol1 & ")<>0),"""")))"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 16728325
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

 

[Peter_SSs]

Sure. Here it is.

Thank you for providing the file. You were certainly right about the speed with data that large!
If interested, you could see how this alternative goes.

Sub RedBlue_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, c As Variant, z As Variant
  Dim rSrch As Range, rFind As Range
  Dim i As Long, j As Long, k As Long, ubb As Long, rws As Long

  Set rSrch = Range("B41:EO1705") ' Range to change the colour of
  Set rFind = Range("B22:EO33")   ' Range containing the values to find
  
  Set d = CreateObject("Scripting.Dictionary")
  b = rFind.Value
  ubb = UBound(b)
  With rSrch
    a = .Value
    rws = UBound(a)
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    For j = 1 To UBound(a, 2)
      d.RemoveAll
      For k = 1 To ubb
        d(b(k, j)) = 1
      Next k
      z = vbNullString
      For i = rws To 1 Step -1
        If d.exists(a(i, j)) Then
          If Len(z) = 0 Then z = a(i, j)
          If a(i, j) = z Then
            c(i, j) = "b"
          Else
            c(i, j) = 1
          End If
        End If
      Next i
    Next j
    Application.ScreenUpdating = False
    .Value = c
    .SpecialCells(xlConstants, xlTextValues).Interior.Color = vbBlue
    .SpecialCells(xlConstants, xlNumbers).Interior.Color = vbRed
    .Value = a
    Application.ScreenUpdating = True
  End With
End Sub

 

[Yamasaki450]

Thank you for providing the file. You were certainly right about the speed with data that large!
If interested, you could see how this alternative goes.

Sub RedBlue_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, c As Variant, z As Variant
  Dim rSrch As Range, rFind As Range
  Dim i As Long, j As Long, k As Long, ubb As Long, rws As Long

  Set rSrch = Range("B41:EO1705") ' Range to change the colour of
  Set rFind = Range("B22:EO33")   ' Range containing the values to find
 
  Set d = CreateObject("Scripting.Dictionary")
  b = rFind.Value
  ubb = UBound(b)
  With rSrch
    a = .Value
    rws = UBound(a)
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    For j = 1 To UBound(a, 2)
      d.RemoveAll
      For k = 1 To ubb
        d(b(k, j)) = 1
      Next k
      z = vbNullString
      For i = rws To 1 Step -1
        If d.exists(a(i, j)) Then
          If Len(z) = 0 Then z = a(i, j)
          If a(i, j) = z Then
            c(i, j) = "b"
          Else
            c(i, j) = 1
          End If
        End If
      Next i
    Next j
    Application.ScreenUpdating = False
    .Value = c
    .SpecialCells(xlConstants, xlTextValues).Interior.Color = vbBlue
    .SpecialCells(xlConstants, xlNumbers).Interior.Color = vbRed
    .Value = a
    Application.ScreenUpdating = True
  End With
End Sub

Lightning fast! Thanks.

 

[Peter_SSs]

Cheers. Thanks for the confirmation. My testing with that large data was that it was marginally faster than the post #8 code but not so much so that you would need to change. My main purpose was to improve on my earlier code!