Excel highlight duplicates with unique values.

DreyFox

Board Regular
Joined
Nov 25, 2020
Messages
61
Office Version
  1. 2016
Platform
  1. Windows
I'm running into a unique situation dealing with duplicates.
I have the following sheets:

Sheet1:
1657219846444.png


Sheet2:
1657219865704.png


Sheet3:
1657219892778.png


My current macro included in the workbook will compare any two columns within individual sheets and delete them.
VBA Code:
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.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,247
Office Version
  1. 2013
Platform
  1. Windows
Try this:

VBA Code:
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
 

Forum statistics

Threads
1,176,104
Messages
5,901,400
Members
434,890
Latest member
creativimama

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top