Macro to find duplicates and display non-duplicates in different sheet

tacosauce31

New Member
Joined
Aug 30, 2017
Messages
6
I'm looking to build a macro that will find duplicates from two different ranges on two different sheets. The data I'd like to compare is usually on column E on both worksheets. I would like the macro to also display non-duplicates on a new sheet.

Can I have some help on this?

Thank you!
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Welcome to the forums

Try the below code

Code:
Sub UniqueValues()

Dim Sh1 As String, Sh2 As String, ws As Worksheet, lRow As Long, lRow2 As Long, Rg As Range

Sh1 = "Sheet1"  ' Change the sheet name as needed
Sh2 = "Sheet2"  ' Change the sheet name as needed

'Creating a new sheet to show non-duplicate values
For Each ws In Worksheets
    If ws.Name = "UniqueValues" Then
        If MsgBox("There is an already existing sheet called ""UniqueValues"", if you continue the sheet will be deleted & a new one will be created" & vbNewLine & "Continue?", vbExclamation + vbYesNo) = vbNo Then
            Exit Sub
        Else:
            Application.DisplayAlerts = False
            Sheets("UniqueValues").Delete
            Application.DisplayAlerts = True
        End If
    End If
Next

'Create the new sheet after making sure it doesn't exist
Sheets.Add.Name = ("UniqueValues")

'Find the last row in the first sheet & copy the data to the new sheet
lRow = Sheets(Sh1).Range("E" & Rows.Count).End(xlUp).Row
Set Rg = Sheets(Sh1).Range("E1:E" & lRow)
Sheets("UniqueValues").Range("A1:A" & lRow) = Rg.Value

'Find the last row in the second sheet & copy the data to the new sheet
lRow2 = Sheets("UniqueValues").Range("A" & Rows.Count).End(xlUp).Row + 1
lRow = Sheets(Sh2).Range("E" & Rows.Count).End(xlUp).Row

Set Rg = Sheets(Sh2).Range("E1:E" & lRow)
Sheets("UniqueValues").Range("A" & lRow2 & ":A" & lRow + lRow2 - 1) = Rg.Value

'Remove the duplicates on the newly created sheet to show unique values only
lRow2 = Sheets("UniqueValues").Range("A" & Rows.Count).End(xlUp).Row
Sheets("UniqueValues").Range("A1:A" & lRow2).RemoveDuplicates Columns:=1, Header:=xlNo

End Sub
 
Upvote 0
mse330,

I've tried your code and it doesn't seem to work. I think it's because of the data consists of number and letters. Is there a way to fix that problem? Because the code does remove the headers from the exports of each column on the unique value sheets which all letters.
 
Upvote 0
mse330,

I've tried your code and it doesn't seem to work. I think it's because of the data consists of number and letters. Is there a way to fix that problem? Because the code does remove the headers from the exports of each column on the unique value sheets which all letters.

tacosauce31,

I have just tried different combinations of numbers, text & mixture of both & it seems to work fine with me. Can you provide sample data of what you have to know what exactly the issue
 
Upvote 0
Hi
Here is another option you can try.

Change the sheet names in red to suit
Code:
Sub FindDupes()
' tacosauce31

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim Dict As Object
    Dim Cl As Range

    Set Sht1 = Sheets("[COLOR=#ff0000]PP[/COLOR]")
    Set Sht2 = Sheets("[COLOR=#ff0000]Entry[/COLOR]")
    Set Dict = CreateObject("scripting.dictionary")
    
    On Error Resume Next
    Sheets("Unique").Activate
    On Error GoTo 0
    If ActiveSheet.Name = "Unique" Then
        Sheets("Unique").Cells.Delete
    Else
        Sheets.Add.Name = "Unique"
    End If
    
    With Dict
        For Each Cl In Sht1.Range("E1", Sht1.Range("E" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
        Next Cl
        For Each Cl In Sht2.Range("E1", Sht2.Range("E" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then .Add Cl.Value, Nothing
        Next Cl
        Sheets("Unique").Range("A1").Resize(.Count) = Application.Transpose(.keys)
    End With

End Sub
 
Upvote 0
tacosauce31,

I have just tried different combinations of numbers, text & mixture of both & it seems to work fine with me. Can you provide sample data of what you have to know what exactly the issue


I believe the issue is that on "Sheet1" the data on column E has spaces as it's imported data from another source. Is there a way in the macro to trim that column before export to "UniqueValues" sheet? It's probably safe to also do it for the "Sheet2" data.
 
Upvote 0
Hi, modified version of my code from post#6, to include the trim
Code:
Sub FindDupes()
' tacosauce31

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim Dict As Object
    Dim Cl As Range

    Set Sht1 = Sheets("PP")
    Set Sht2 = Sheets("Entry")
    Set Dict = CreateObject("scripting.dictionary")
    
    On Error Resume Next
    Sheets("Unique").Activate
    On Error GoTo 0
    If ActiveSheet.Name = "Unique" Then
        Sheets("Unique").Cells.Delete
    Else
        Sheets.Add.Name = "Unique"
    End If
    
    With Dict
        For Each Cl In Sht1.Range("E1", Sht1.Range("E" & Rows.Count).End(xlUp))
            If Not .exists(Trim(Cl.Value)) Then .Add Trim(Cl.Value), Nothing
        Next Cl
        For Each Cl In Sht2.Range("E1", Sht2.Range("E" & Rows.Count).End(xlUp))
            If Not .exists(Trim(Cl.Value)) Then .Add Trim(Cl.Value), Nothing
        Next Cl
        Sheets("Unique").Range("A1").Resize(.Count) = Application.Transpose(.keys)
    End With

End Sub
 
Upvote 0
Sheet 1[TABLE="width: 500"]
<tbody>[TR]
[TD]Column E[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl108, width: 149"]japsiudvas7962943908[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]askdjfvhbawoubio42342no[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]hvbsiufhb2u4g23jnd[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]asdiknb[43iu2113lkn3[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2
[TABLE="width: 500"]
<tbody>[TR]
[TD]Column E[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]japsiudvas7962943908[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]askdjfvhbawoubio42342no[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]hvbsiufhb2u4g23jnd[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][TABLE="width: 149"]
<tbody>[TR]
[TD="class: xl110, width: 149"]asd9va812sr98va[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I hope this sample data helps. I'm getting the same results for both codes. In this sample data, Sheet 3 should only have one value and its the last value on Sheet 2.

Thank you!
 
Upvote 0
How about
Code:
Sub FindNonDupes()
' tacosauce31

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim Cl As Range

    Set Sht1 = Sheets("PP")
    Set Sht2 = Sheets("Entry")
    
    On Error Resume Next
    Sheets("Unique").Activate
    On Error GoTo 0
    If ActiveSheet.Name = "Unique" Then
        Sheets("Unique").Cells.Delete
    Else
        Sheets.Add.Name = "Unique"
    End If
    
    For Each Cl In Sht1.Range("E1", Sht1.Range("E" & Rows.Count).End(xlUp))
        If WorksheetFunction.CountIf(Sht2.Columns(5), Cl.Value) + WorksheetFunction.CountIf(Sht1.Columns(5), Cl.Value) = 1 Then
            Sheets("Unique").Range("A" & Rows.Count).End(xlUp).Offset(1) = Cl.Value
        End If
    Next Cl

End Sub
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

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
Back
Top