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...

 

[Sam_D_Ben]

Quick question—why is 60 marked in red in your file? It doesn't seem to be a duplicate.

 

[Fuji]

try

Sub test()
    Dim c As Range, r As Range, myArea As Range, a, i&, ii&, myAreas As Areas, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set myAreas = Columns(2).SpecialCells(2, 1).Areas
    For Each myArea In myAreas
        With myArea.CurrentRegion
            .Interior.ColorIndex = xlNone
            a = .Value
            For ii = 1 To UBound(a, 2)
                For i = UBound(a, 1) To 1 Step -1
                    If a(i, ii) <> "" Then
                        If Not dic.exists(a(i, ii)) Then
                            If WorksheetFunction.CountIf(.Columns(ii), .Cells(i, ii)) > 1 Then
                                Set dic(a(i, ii)) = .Cells(i, ii)
                                If c Is Nothing Then
                                    Set c = .Cells(i, ii)
                                Else
                                    Set c = Union(.Cells(i, ii), c)
                                End If
                            End If
                        Else
                            If r Is Nothing Then
                                Set r = .Cells(i, ii)
                            Else
                                Set r = Union(.Cells(i, ii), r)
                            End If
                        End If
                    End If
                Next
                dic.RemoveAll
            Next
        End With
        If Not r Is Nothing Then
            r.Interior.Color = vbRed
            c.Interior.Color = vbBlue
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[fahad_ibnfurjan]

Test.xlsx
	B	C	D	E	F	G	H	I	J	K
2	54	53	25	-28	29	61	-57	28	53	-57
3	57	45	20	-25	29	6.3	-54	25	45	-54
4	51	55	31	-14	37	57	-51	14	45	-51
5	38	44	2.1	-23	28	58	-51	23	44	-51
6	52	45	32	-1.3	37	55	-50	1.3	45	-50
7	59	52	25	-27	32	66	-59	27	52	-59
8	50	46	26	-20	30	54	-50	20	46	-50
9	45	59	27	-15	30	48	-45	15	42	-45
10	58	50	24	-26	32	66	-58	26	50	-58
11	64	53	35	-20	31	47	-51	20	55	-51
12	52	50	30	-20	32	54	-52	20		-52
13	42	46	24	-22	20	38			46	-42
14	51	47	33	-14	37			14	47	-51
15	48	33	32	-12		52	-48	12		-48
16	59	51	25		33	67	-59	26	51	-59
17	56		24	-27	29	55	-56	27	57	-56
18	54	50	24	-22	32	58	-54	22	50	-54
19	34	57	30	-27	29	55	0.56	27	57	-56
20	60	52	22	-30	30	68	-60	30	52	-60
21	56	47	24	-23	33	65	0.56	23
22	40	53	28	-25	31				53	-56
23	36	61	24	-20		72	0.58	20		-58
24	52	63	30	-25	27	49	-52	25	55	-52
25
26	34	29	24	-5	29	39	-34	5	29	-34
27	36	31	24	-7	29	41	-36	7	31	-36
28	38	33	24	-9	29	43	-38	9	33	-38
29	40	35	24	-11	29	45	-40	11	35	-40
30	42	37	24	-13	29	47	-42	13	37	-42
31	44	39	24	-15	29	49	-44	15	39	-44
32	46	41	24	-17	29	51	-46	17	41	-46
33	48	43	24	-19	29	53	-48	19	43	-48
34	50	45	24	-21	29	55	-50	21	45	-50
35	52	47	24	-23	29	57	-52	23	47	-52
36	54	49	24	-25	29	59	-54	25	49	-54
37	56	51	24	-27	29	61	-56	27	51	-56
38	58	53	24	-29	29	63	-58	29	53	-58
39	60	55	24	-31	29	65	-60	31	55	-60
40	62	57	24	-33	29	67	-62	33	57	-62
41	64	59	24	-35	29	69	-64	35	59	-64
42	66	61	24	-37	29	71	-66	37	61	-66
43	68	63	24	-39	29	73	-68	39	63	-68
Sheet 1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B2:K24	Expression	=B2=INDEX(B$2:B$24,MAX(IFERROR(SEQUENCE(ROWS($B$2:$K$24))/(COUNTIF(B$2:B$24,B$2:B$24)>1),"")))	text	NO
B2:K24	Expression	=AND(COUNTIF(B$2:B$43,B2)>1,COUNTIF(B$29:B$40,B2)>=1)	text	NO

 

[Georgiboy]

Maybe the below:

Sub test()
    Dim rngSrch As Range, rngFind As Range, rCell As Range, rngC As Range
    Dim foundCell As Range, foundCells As Range, pCell As Range, lastDup As Range
    Dim firstAddress As String
    Dim lcl As Long
    
    Set rngSrch = Range("A2:J24") ' Range to change the colour of
    Set rngFind = Range("A29:J40") ' Range containing the values to find
    
    Application.ScreenUpdating = False
    For Each rngC In rngSrch.Columns
        For Each rCell In rngFind.Columns(rngC.Column).Cells
            Set foundCell = rngC.Find(rCell.Value, rngC.Cells(1, 1), , xlWhole)
            If Not foundCell Is Nothing Then
                firstAddress = foundCell.Address
                Set foundCells = foundCell
                Do
                    Set foundCell = rngC.FindNext(foundCell)
                    If Not foundCell Is Nothing And foundCell.Address <> firstAddress Then
                        Set foundCells = Union(foundCells, foundCell)
                    Else
                        Exit Do
                    End If
                Loop
                For Each pCell In foundCells
                    If pCell.Row > lcl Then lcl = pCell.Row: Set lastDup = foundCells
                Next pCell
                foundCells.Interior.Color = vbRed
            End If
        Next rCell
        If Not lastDup Is Nothing Then lastDup.Interior.Color = vbBlue
        Set lastDup = Nothing
        lcl = 0
    Next rngC
    Application.ScreenUpdating = True
End Sub

Book1
	A	B	C	D	E	F	G	H	I	J	K
1
2	54	54	54	54	54	54	54	54	54	54
3	57	57	57	57	57	57	57	57	57	57
4	51	51	51	51	51	51	51	51	51	51
5	38	38	38	38	38	38	38	38	38	38
6	52	52	52	52	52	52	52	52	52	52
7	59	59	59	59	59	40	59	59	59	59
8	50	50	50	50	50	50	50	50	50	50
9	45	45	45	45	45	45	45	45	45	45
10	58	58	58	58	58	58	58	58	58	58
11	64	64	64	64	64	64	64	64	64	64
12	52	52	52	52	52	52	52	52	52	52
13	42	42	42	42	42	42	42	42	42	42
14	51	51	51	51	51	40	51	51	51	51
15	48	48	48	48	48	48	48	48	48	48
16	59	59	59	59	59	59	59	59	59	59
17	56	56	56	56	56	56	56	56	56	56
18	54	54	54	54	54	54	54	54	54	54
19	34	34	34	34	34	34	34	34	34	34
20	60	60	60	60	60	40	60	60	60	60
21	56	56	56	56	56	56	56	56	56	56
22	40	40	40	40	40	40	40	40	40	40
23	36	36	36	36	36	36	36	36	36	36
24	52	52	52	52	52	52	52	52	52	52
25
26	34	34	34	34	34	34	34	34	34	34
27	36	36	36	36	36	36	36	36	36	36
28	38	38	38	38	38	38	38	38	38	38
29	40	40	100	100	100	100	100	100	100	100
30	42	42	42	42	100	42	42	42	42	42
31	44	44	44	44	100	44	44	44	44	44
32	46	46	46	46	100	46	46	46	46	46
33	48	48	48	48	100	34	34	34	34	34
34	50	50	50	50	100	50	50	50	50	50
35	52	99	99	99	100	40	59	99	40	59
36	54	200	54	200	100	54	54	54	54	54
37	56	56	56	101	100	101	101	101	101	101
38	58	58	58	58	100	58	58	58	58	58
39	60	60	60	60	100	102	102	102	102	102
40	62	62	62	62	100	62	62	62	62	62
41	64	64	64	64	64	64	64	64	64	64
42	66	66	66	66	66	66	66	66	66	66
43	68	68	68	68	68	68	68	68	68	68
44	68	68	68	68	68	68	68	68	68	68
45
Sheet1

 

[Yamasaki450]

Maybe the below:

Sub test()
    Dim rngSrch As Range, rngFind As Range, rCell As Range, rngC As Range
    Dim foundCell As Range, foundCells As Range, pCell As Range, lastDup As Range
    Dim firstAddress As String
    Dim lcl As Long
   
    Set rngSrch = Range("A2:J24") ' Range to change the colour of
    Set rngFind = Range("A29:J40") ' Range containing the values to find
   
    Application.ScreenUpdating = False
    For Each rngC In rngSrch.Columns
        For Each rCell In rngFind.Columns(rngC.Column).Cells
            Set foundCell = rngC.Find(rCell.Value, rngC.Cells(1, 1), , xlWhole)
            If Not foundCell Is Nothing Then
                firstAddress = foundCell.Address
                Set foundCells = foundCell
                Do
                    Set foundCell = rngC.FindNext(foundCell)
                    If Not foundCell Is Nothing And foundCell.Address <> firstAddress Then
                        Set foundCells = Union(foundCells, foundCell)
                    Else
                        Exit Do
                    End If
                Loop
                For Each pCell In foundCells
                    If pCell.Row > lcl Then lcl = pCell.Row: Set lastDup = foundCells
                Next pCell
                foundCells.Interior.Color = vbRed
            End If
        Next rCell
        If Not lastDup Is Nothing Then lastDup.Interior.Color = vbBlue
        Set lastDup = Nothing
        lcl = 0
    Next rngC
    Application.ScreenUpdating = True
End Sub

Book1
	A	B	C	D	E	F	G	H	I	J	K
1
2	54	54	54	54	54	54	54	54	54	54
3	57	57	57	57	57	57	57	57	57	57
4	51	51	51	51	51	51	51	51	51	51
5	38	38	38	38	38	38	38	38	38	38
6	52	52	52	52	52	52	52	52	52	52
7	59	59	59	59	59	40	59	59	59	59
8	50	50	50	50	50	50	50	50	50	50
9	45	45	45	45	45	45	45	45	45	45
10	58	58	58	58	58	58	58	58	58	58
11	64	64	64	64	64	64	64	64	64	64
12	52	52	52	52	52	52	52	52	52	52
13	42	42	42	42	42	42	42	42	42	42
14	51	51	51	51	51	40	51	51	51	51
15	48	48	48	48	48	48	48	48	48	48
16	59	59	59	59	59	59	59	59	59	59
17	56	56	56	56	56	56	56	56	56	56
18	54	54	54	54	54	54	54	54	54	54
19	34	34	34	34	34	34	34	34	34	34
20	60	60	60	60	60	40	60	60	60	60
21	56	56	56	56	56	56	56	56	56	56
22	40	40	40	40	40	40	40	40	40	40
23	36	36	36	36	36	36	36	36	36	36
24	52	52	52	52	52	52	52	52	52	52
25
26	34	34	34	34	34	34	34	34	34	34
27	36	36	36	36	36	36	36	36	36	36
28	38	38	38	38	38	38	38	38	38	38
29	40	40	100	100	100	100	100	100	100	100
30	42	42	42	42	100	42	42	42	42	42
31	44	44	44	44	100	44	44	44	44	44
32	46	46	46	46	100	46	46	46	46	46
33	48	48	48	48	100	34	34	34	34	34
34	50	50	50	50	100	50	50	50	50	50
35	52	99	99	99	100	40	59	99	40	59
36	54	200	54	200	100	54	54	54	54	54
37	56	56	56	101	100	101	101	101	101	101
38	58	58	58	58	100	58	58	58	58	58
39	60	60	60	60	100	102	102	102	102	102
40	62	62	62	62	100	62	62	62	62	62
41	64	64	64	64	64	64	64	64	64	64
42	66	66	66	66	66	66	66	66	66	66
43	68	68	68	68	68	68	68	68	68	68
44	68	68	68	68	68	68	68	68	68	68
45
Sheet1

Hey man

Thanks for this VBA code... It works fine until i change the ranges.
I uploaded worksheet with different ranges... Try it yourself just change the ranges in code and it wont work correctly anymore...

Can you fix this?

Correct ranges for worksheet i uploaded are B2:K24 and B29:K40 right? Or im doing something wrong?

Loading Google Sheets

 

[Peter_SSs]

This is what I came up with

Sub RedBlue()
    Dim a As Variant, b As Variant
    Dim rSrch As Range, rFind As Range, rRed As Range, rBlue As Range, rLast As Range
    Dim i As Long, j As Long, k As Long, rws As Long, ubb As Long
    
    Set rSrch = Range("B2:K24") ' Range to change the colour of
    Set rFind = Range("B29:K40") ' Range containing the values to find
    
    b = rFind.Value
    ubb = UBound(b)
    With rSrch
      .Interior.Color = xlNone
      a = .Value
      rws = UBound(a)
      Set rRed = .Cells(.Rows.Count + 1, 1)
      Set rBlue = .Cells(.Rows.Count + 1, 1)
      For j = 1 To UBound(a, 2)
        Set rLast = Nothing
        For i = rws To 1 Step -1
          For k = 1 To ubb
            If a(i, j) = b(k, j) Then
              If rLast Is Nothing Then Set rLast = .Cells(i, j)
              If a(i, j) = rLast.Value Then
                Set rBlue = Union(rBlue, .Cells(i, j))
              Else
                Set rRed = Union(rRed, .Cells(i, j))
              End If
            End If
          Next k
        Next i
      Next j
      rRed.Interior.Color = vbRed
      rBlue.Interior.Color = vbBlue
      .Cells(.Rows.Count + 1, 1).Interior.Color = xlNone
    End With
End Sub

My results:

Yamasaki450.xlsm
	B	C	D	E	F	G	H	I	J	K
1
2	54	53	25	-28	29	61	-57	28	53	-57
3	57	45	20	-25	29	63	-54	25	45	-54
4	51	55	31	-14	37	57	-51	14	45	-51
5	38	44	21	-23	28	58	-51	23	44	-51
6	52	45	32	-13	37	55	-50	13	45	-50
7	59	52	25	-27	32	66	-59	27	52	-59
8	50	46	26	-20	30	54	-50	20	46	-50
9	45	59	27	-15	30	48	-45	15	42	-45
10	58	50	24	-26	32	66	-58	26	50	-58
11	64	53	35	-20	31	47	-51	20	55	-51
12	52	50	30	-20	32	54	-52	20	50	-52
13	42	46	24	-22	20	38	-42	22	46	-42
14	51	47	33	-14	37	55	-51	14	47	-51
15	48	33	32	-12	36	52	-48	12	44	-48
16	59	51	25	-26	33	67	-59	26	51	-59
17	56	57	30	-27	29	55	-56	27	57	-56
18	54	50	28	-22	32	58	-54	22	50	-54
19	34	57	30	-27	29	55	-56	27	57	-56
20	60	52	22	-30	30	68	-60	30	52	-60
21	56	47	24	-23	33	65	-56	23	47	-56
22	40	53	28	-25	31	59	-56	25	53	-56
23	36	61	24	-20	38	72	-58	20	44	-58
24	52	63	30	-25	27	49	-52	25	55	-52
25
26	34	29	24	-5	29	39	-34	5	29	-34
27	36	31	24	-7	29	41	-36	7	31	-36
28	38	33	24	-9	29	43	-38	9	33	-38
29	40	35	24	-11	29	45	-40	11	35	-40
30	42	37	24	-13	29	47	-42	13	37	-42
31	44	39	24	-15	29	49	-44	15	39	-44
32	46	41	24	-17	29	51	-46	17	41	-46
33	48	43	24	-19	29	53	-48	19	43	-48
34	50	45	24	-21	29	55	-50	21	45	-50
35	52	47	24	-23	29	57	-52	23	47	-52
36	54	49	24	-25	29	59	-54	25	49	-54
37	56	51	24	-27	29	61	-56	27	51	-56
38	58	53	24	-29	29	63	-58	29	53	-58
39	60	55	24	-31	29	65	-60	31	55	-60
40	62	57	24	-33	29	67	-62	33	57	-62
41	64	59	24	-35	29	69	-64	35	59	-64
42	66	61	24	-37	29	71	-66	37	61	-66
43	68	63	24	-39	29	73	-68	39	63	-68
Sheet1 (3)

 

[Georgiboy]

Here is the fixed code:

Sub test()
    Dim rngSrch As Range, rngFind As Range, rCell As Range, rngC As Range
    Dim foundCell As Range, foundCells As Range, pCell As Range, lastDup As Range
    Dim firstAddress As String
    Dim lcl As Long
    
    Set rngSrch = Range("B2:K24") ' Range to change the colour of
    Set rngFind = Range("B29:K40") ' Range containing the values to find
    
    Application.ScreenUpdating = False
    For Each rngC In rngSrch.Columns
        For Each rCell In rngFind.Columns(rngC.Column - rngSrch.Column + 1).Cells
            Set foundCell = rngC.Find(rCell.Value, rngC.Cells(1, 1), , xlWhole)
            If Not foundCell Is Nothing Then
                firstAddress = foundCell.Address
                Set foundCells = foundCell
                Do
                    Set foundCell = rngC.FindNext(foundCell)
                    If Not foundCell Is Nothing And foundCell.Address <> firstAddress Then
                        Set foundCells = Union(foundCells, foundCell)
                    Else
                        Exit Do
                    End If
                Loop
                For Each pCell In foundCells
                    If pCell.Row > lcl Then lcl = pCell.Row: Set lastDup = foundCells
                Next pCell
                foundCells.Interior.Color = vbRed
            End If
        Next rCell
        If Not lastDup Is Nothing Then lastDup.Interior.Color = vbBlue
        Set lastDup = Nothing
        lcl = 0
    Next rngC
    Application.ScreenUpdating = True
End Sub

 

[Yamasaki450]

This is what I came up with

Sub RedBlue()
    Dim a As Variant, b As Variant
    Dim rSrch As Range, rFind As Range, rRed As Range, rBlue As Range, rLast As Range
    Dim i As Long, j As Long, k As Long, rws As Long, ubb As Long
   
    Set rSrch = Range("B2:K24") ' Range to change the colour of
    Set rFind = Range("B29:K40") ' Range containing the values to find
   
    b = rFind.Value
    ubb = UBound(b)
    With rSrch
      .Interior.Color = xlNone
      a = .Value
      rws = UBound(a)
      Set rRed = .Cells(.Rows.Count + 1, 1)
      Set rBlue = .Cells(.Rows.Count + 1, 1)
      For j = 1 To UBound(a, 2)
        Set rLast = Nothing
        For i = rws To 1 Step -1
          For k = 1 To ubb
            If a(i, j) = b(k, j) Then
              If rLast Is Nothing Then Set rLast = .Cells(i, j)
              If a(i, j) = rLast.Value Then
                Set rBlue = Union(rBlue, .Cells(i, j))
              Else
                Set rRed = Union(rRed, .Cells(i, j))
              End If
            End If
          Next k
        Next i
      Next j
      rRed.Interior.Color = vbRed
      rBlue.Interior.Color = vbBlue
      .Cells(.Rows.Count + 1, 1).Interior.Color = xlNone
    End With
End Sub

My results:

Yamasaki450.xlsm
	B	C	D	E	F	G	H	I	J	K
1
2	54	53	25	-28	29	61	-57	28	53	-57
3	57	45	20	-25	29	63	-54	25	45	-54
4	51	55	31	-14	37	57	-51	14	45	-51
5	38	44	21	-23	28	58	-51	23	44	-51
6	52	45	32	-13	37	55	-50	13	45	-50
7	59	52	25	-27	32	66	-59	27	52	-59
8	50	46	26	-20	30	54	-50	20	46	-50
9	45	59	27	-15	30	48	-45	15	42	-45
10	58	50	24	-26	32	66	-58	26	50	-58
11	64	53	35	-20	31	47	-51	20	55	-51
12	52	50	30	-20	32	54	-52	20	50	-52
13	42	46	24	-22	20	38	-42	22	46	-42
14	51	47	33	-14	37	55	-51	14	47	-51
15	48	33	32	-12	36	52	-48	12	44	-48
16	59	51	25	-26	33	67	-59	26	51	-59
17	56	57	30	-27	29	55	-56	27	57	-56
18	54	50	28	-22	32	58	-54	22	50	-54
19	34	57	30	-27	29	55	-56	27	57	-56
20	60	52	22	-30	30	68	-60	30	52	-60
21	56	47	24	-23	33	65	-56	23	47	-56
22	40	53	28	-25	31	59	-56	25	53	-56
23	36	61	24	-20	38	72	-58	20	44	-58
24	52	63	30	-25	27	49	-52	25	55	-52
25
26	34	29	24	-5	29	39	-34	5	29	-34
27	36	31	24	-7	29	41	-36	7	31	-36
28	38	33	24	-9	29	43	-38	9	33	-38
29	40	35	24	-11	29	45	-40	11	35	-40
30	42	37	24	-13	29	47	-42	13	37	-42
31	44	39	24	-15	29	49	-44	15	39	-44
32	46	41	24	-17	29	51	-46	17	41	-46
33	48	43	24	-19	29	53	-48	19	43	-48
34	50	45	24	-21	29	55	-50	21	45	-50
35	52	47	24	-23	29	57	-52	23	47	-52
36	54	49	24	-25	29	59	-54	25	49	-54
37	56	51	24	-27	29	61	-56	27	51	-56
38	58	53	24	-29	29	63	-58	29	53	-58
39	60	55	24	-31	29	65	-60	31	55	-60
40	62	57	24	-33	29	67	-62	33	57	-62
41	64	59	24	-35	29	69	-64	35	59	-64
42	66	61	24	-37	29	71	-66	37	61	-66
43	68	63	24	-39	29	73	-68	39	63	-68
Sheet1 (3)

Here is the fixed code:

Sub test()
    Dim rngSrch As Range, rngFind As Range, rCell As Range, rngC As Range
    Dim foundCell As Range, foundCells As Range, pCell As Range, lastDup As Range
    Dim firstAddress As String
    Dim lcl As Long
   
    Set rngSrch = Range("B2:K24") ' Range to change the colour of
    Set rngFind = Range("B29:K40") ' Range containing the values to find
   
    Application.ScreenUpdating = False
    For Each rngC In rngSrch.Columns
        For Each rCell In rngFind.Columns(rngC.Column - rngSrch.Column + 1).Cells
            Set foundCell = rngC.Find(rCell.Value, rngC.Cells(1, 1), , xlWhole)
            If Not foundCell Is Nothing Then
                firstAddress = foundCell.Address
                Set foundCells = foundCell
                Do
                    Set foundCell = rngC.FindNext(foundCell)
                    If Not foundCell Is Nothing And foundCell.Address <> firstAddress Then
                        Set foundCells = Union(foundCells, foundCell)
                    Else
                        Exit Do
                    End If
                Loop
                For Each pCell In foundCells
                    If pCell.Row > lcl Then lcl = pCell.Row: Set lastDup = foundCells
                Next pCell
                foundCells.Interior.Color = vbRed
            End If
        Next rCell
        If Not lastDup Is Nothing Then lastDup.Interior.Color = vbBlue
        Set lastDup = Nothing
        lcl = 0
    Next rngC
    Application.ScreenUpdating = True
End Sub

What can i say guys. Hats off. Both codes work but the one that Georgiboy posted is much faster when it comes to larger amount of data.
Thanks to both of you. Cant thank you enough.

Have a nice day.

 

[Yamasaki450]

Test.xlsx
	B	C	D	E	F	G	H	I	J	K
2	54	53	25	-28	29	61	-57	28	53	-57
3	57	45	20	-25	29	6.3	-54	25	45	-54
4	51	55	31	-14	37	57	-51	14	45	-51
5	38	44	2.1	-23	28	58	-51	23	44	-51
6	52	45	32	-1.3	37	55	-50	1.3	45	-50
7	59	52	25	-27	32	66	-59	27	52	-59
8	50	46	26	-20	30	54	-50	20	46	-50
9	45	59	27	-15	30	48	-45	15	42	-45
10	58	50	24	-26	32	66	-58	26	50	-58
11	64	53	35	-20	31	47	-51	20	55	-51
12	52	50	30	-20	32	54	-52	20		-52
13	42	46	24	-22	20	38			46	-42
14	51	47	33	-14	37			14	47	-51
15	48	33	32	-12		52	-48	12		-48
16	59	51	25		33	67	-59	26	51	-59
17	56		24	-27	29	55	-56	27	57	-56
18	54	50	24	-22	32	58	-54	22	50	-54
19	34	57	30	-27	29	55	0.56	27	57	-56
20	60	52	22	-30	30	68	-60	30	52	-60
21	56	47	24	-23	33	65	0.56	23
22	40	53	28	-25	31				53	-56
23	36	61	24	-20		72	0.58	20		-58
24	52	63	30	-25	27	49	-52	25	55	-52
25
26	34	29	24	-5	29	39	-34	5	29	-34
27	36	31	24	-7	29	41	-36	7	31	-36
28	38	33	24	-9	29	43	-38	9	33	-38
29	40	35	24	-11	29	45	-40	11	35	-40
30	42	37	24	-13	29	47	-42	13	37	-42
31	44	39	24	-15	29	49	-44	15	39	-44
32	46	41	24	-17	29	51	-46	17	41	-46
33	48	43	24	-19	29	53	-48	19	43	-48
34	50	45	24	-21	29	55	-50	21	45	-50
35	52	47	24	-23	29	57	-52	23	47	-52
36	54	49	24	-25	29	59	-54	25	49	-54
37	56	51	24	-27	29	61	-56	27	51	-56
38	58	53	24	-29	29	63	-58	29	53	-58
39	60	55	24	-31	29	65	-60	31	55	-60
40	62	57	24	-33	29	67	-62	33	57	-62
41	64	59	24	-35	29	69	-64	35	59	-64
42	66	61	24	-37	29	71	-66	37	61	-66
43	68	63	24	-39	29	73	-68	39	63	-68
Sheet 1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B2:K24	Expression	=B2=INDEX(B$2:B$24,MAX(IFERROR(SEQUENCE(ROWS($B$2:$K$24))/(COUNTIF(B$2:B$24,B$2:B$24)>1),"")))	text	NO
B2:K24	Expression	=AND(COUNTIF(B$2:B$43,B2)>1,COUNTIF(B$29:B$40,B2)>=1)	text	NO

This also works but its easier to change ranges in VBA code...
Thanks to you to.