Excel highlight duplicates with unique values.

[DreyFox]

I'm running into a unique situation dealing with duplicates.
I have the following sheets:

Sheet1:

Sheet2:

Sheet3:

My current macro included in the workbook will compare any two columns within individual sheets and delete them.

Sub delete()
Dim x As Range
Dim lstrw As Long
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
    lstrw = sh.Range("A" & Rows.Count).End(xlUp).Row
    Set x = sh.Range("A1:B10000" & lstrw)
    x.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
Next sh
End Sub

For example in sheet1, C-3 and C-3 occurs twice, so the macro will get rid of one occurrence of C-3. Same with Sheet2 and Sheet3.

What I would like additionally, is for the macro to compare say A-1 with A-2, then make both cells color as red text. For example, all cells in Sheet 1 other than C-3 would be red. Again for example in Sheet3 after the duplicate deletion happens, all cells other than A-1 would be highlighted red.

Once all the red cells are highlighted, I'd like to create a new sheet say "Duplicated List" then create links to all sheets that contain duplicates. For example consider a Sheet4 and Sheet5 where duplicates don't exist at all. The links should only be created for Sheet1, Sheet2 and Sheet3.

Please advise me in how to achieve this. Thank you.

 

[DanteAmor]

Try this:

Sub delete_and_highlight_duplicates()
  Dim sh As Worksheet, sh1 As Worksheet
  Dim c As Range, rng As Range
  Dim dups As Boolean
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Duplicated List")
  sh1.Cells.Clear
  
  For Each sh In ThisWorkbook.Sheets
    dups = False
    Select Case sh.Name
      Case sh1.Name, "report", "etc"  'Sheets not checked
      Case Else
        Set rng = sh.Range("A1", sh.Range("B" & Rows.Count).End(3))
        rng.Interior.ColorIndex = xlNone
        For Each c In rng.Columns(1).Cells
          If WorksheetFunction.CountIfs(rng.Columns(1), c.Value, rng.Columns(2), c.Offset(, 1).Value) = 1 Then
            c.Resize(1, 2).Interior.Color = vbRed
          Else
            dups = True
          End If
        Next
        If dups Then
          rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
          sh1.Hyperlinks.Add sh1.Range("A" & Rows.Count).End(3)(2), "", "'" & sh.Name & "'!A1", , sh.Name
        End If
    End Select
  Next sh
  
  Application.ScreenUpdating = True
End Sub