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

[tacosauce31]

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!

 

[RedBeard]

This is a nice little video: YouTube

 

[mse330]

Welcome to the forums

Try the below 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

 

[tacosauce31]

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.

 

[mse330]

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

 

[Fluff]

Hi
Here is another option you can try.

Change the sheet names in red to suit

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

 

[tacosauce31]

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.

 

[Fluff]

Hi, modified version of my code from post#6, to include the trim

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

 

[tacosauce31]

Sheet 1

Column E
japsiudvas7962943908 <tbody> </tbody>
askdjfvhbawoubio42342no <tbody> </tbody>
hvbsiufhb2u4g23jnd <tbody> </tbody>
asdiknb[43iu2113lkn3 <tbody> </tbody>

<tbody>
</tbody>

Sheet 2

Column E
japsiudvas7962943908 <tbody> </tbody>
askdjfvhbawoubio42342no <tbody> </tbody>
hvbsiufhb2u4g23jnd <tbody> </tbody>
asd9va812sr98va <tbody> </tbody>

<tbody>
</tbody>

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!

 

[Fluff]

How about

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