Delete Double Entries

dizzyfreedom

New Member
Joined
Jul 19, 2012
Messages
6
I need to delete pairs of rows that contain the same data in column G [which are email addresses]. I have 2 sets of data from seperate sources, merged together in a single sheet and sorted on Col G. Column A-F also have additional info [name/title/city/state, etc]. I have around 4000 rows. I need to be left with a set of data that is unique to my primary source, so anything appearing in both data sources can go. I should be left with around 800 rows [email addresses] after eliminating them.

Can you help with this? Any suggestions are welcomed! Thank you!!!
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Momentman

Well-known Member
Joined
Jan 11, 2012
Messages
4,066
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Do you mean removing duplicates from Column G, i.e any row that has a duplicate mail in columnG should be deleted
 

konew1

Well-known Member
Joined
Oct 17, 2007
Messages
2,287
In a spare column put =COUNTIF($G:$G,G1) on the first line and copy down all 4000 rows. Convert that column to values, then sort by the column and delete all rows reporting more than one instance of the email address. Then delete the data from the extra column
 

Momentman

Well-known Member
Joined
Jan 11, 2012
Messages
4,066
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

In a spare column put =COUNTIF($G:$G,G1) on the first line and copy down all 4000 rows. Convert that column to values, then sort by the column and delete all rows reporting more than one instance of the email address. Then delete the data from the extra column

That would definitely work

You could also run this macro

Code:
Sub deletedups()
lastrow = Range("G1").End(xlDown).Row
For I = lastrow To 1 Step -1
    If Application.WorksheetFunction.CountIf(Range("G:G"), Cells(I, "G")) > 1 Then
        Rows(I).EntireRow.Delete
    End If
Next I
End Sub
 

dizzyfreedom

New Member
Joined
Jul 19, 2012
Messages
6
That would definitely work

You could also run this macro

Code:
Sub deletedups()
lastrow = Range("G1").End(xlDown).Row
For I = lastrow To 1 Step -1
    If Application.WorksheetFunction.CountIf(Range("G:G"), Cells(I, "G")) > 1 Then
        Rows(I).EntireRow.Delete
    End If
Next I
End Sub

Thank you so much! Ran the macro, but it left the original entry. So instead of two of the same, only one exists. I need to remove BOTH entries to create a whole new list of emails. I also tried the =COUNTIF($G:$G,G1) as suggested and I couldn't get it to sort by that new column. I'd have to manually go down 4800 rows and find them that are labeled 2...Plus it seemed to label a third row 2 which was not a duplicate...it was a similar email..but not a duplicate.
 

Momentman

Well-known Member
Joined
Jan 11, 2012
Messages
4,066
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

This might not be so efficient

Code:
Sub deletedups()
lastrow = Range("G1").End(xlDown).Row
For I = 1 To lastrow Step 1
    For j = (I + 1) To lastrow Step 1
        If Cells(I, "G").Value = Cells(j, "G").Value Then
            Cells(I, "G").Value = "To be deleted"
            Cells(j, "G").Value = "To be deleted"
        End If
    Next j
Next I
For k = lastrow To 1 Step -1
    If Cells(k, "G").Value = "To be deleted" Then
        Rows(k).EntireRow.Delete
    End If
Next k
End Sub
 

dizzyfreedom

New Member
Joined
Jul 19, 2012
Messages
6
This might not be so efficient

Code:
Sub deletedups()
lastrow = Range("G1").End(xlDown).Row
For I = 1 To lastrow Step 1
    For j = (I + 1) To lastrow Step 1
        If Cells(I, "G").Value = Cells(j, "G").Value Then
            Cells(I, "G").Value = "To be deleted"
            Cells(j, "G").Value = "To be deleted"
        End If
    Next j
Next I
For k = lastrow To 1 Step -1
    If Cells(k, "G").Value = "To be deleted" Then
        Rows(k).EntireRow.Delete
    End If
Next k
End Sub

No...it didn't work.
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,714
Hi dizzyfreedom,

Try this (initially on a copy of your data as the results cannot be undone if they're not as expected):

Code:
ption Explicit
Sub Macro1()

    'http://www.mrexcel.com/forum/showthread.php?648086-Delete-Double-Entries

    Dim rngCell As Range, _
        rngMyData As Range, _
        rngMyDeletion As Range
        
    Set rngMyData = Range("G1:G" & Cells(Rows.Count, "G").End(xlUp).Row)
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngMyData
        If Evaluate("COUNTIF(" & rngMyData.Address & "," & rngCell.Address & ")") > 1 Then
            If rngMyDeletion Is Nothing Then
                Set rngMyDeletion = rngCell
            Else
                Set rngMyDeletion = Union(rngMyDeletion, rngCell)
            End If
        End If
    Next rngCell
    
    If Not rngMyDeletion Is Nothing Then
        rngMyDeletion.EntireRow.Delete
        Application.ScreenUpdating = True
        MsgBox "All duplicates have now been deleted.", vbInformation, "Delete Duplicates Editor"
    Else
        Application.ScreenUpdating = True
        MsgBox "No rows were deleted as no duplicated were identified.", vbExclamation, "Delete Duplicates Editor"
    End If
    
    Set rngMyData = Nothing: Set rngMyDeletion = Nothing
    
End Sub

Regards,

Robert
 

Momentman

Well-known Member
Joined
Jan 11, 2012
Messages
4,066
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
No...it didn't work.

What are the results like cos i ran it on a sample and it did work.

The approach was to check through and every line with duplicates, change the value in column G to "TO BE DELETED", In this modified version, The text "To be deleted" is in column Z.

The macro then checks to see for lines with "To be deleted" and deletes them

Code:
Sub deletedups()
lastrow = Range("G1").End(xlDown).Row
For I = 1 To lastrow Step 1
    For j = (I + 1) To lastrow Step 1
        If Cells(I, "G").Value = Cells(j, "G").Value Then
            Cells(I, "Z").Value = "To be deleted"
            Cells(j, "Z").Value = "To be deleted"
        End If
    Next j
Next I
For k = lastrow To 1 Step -1
    If Cells(k, "Z").Value = "To be deleted" Then
        Rows(k).EntireRow.Delete
    End If
Next k
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,123,535
Messages
5,602,217
Members
414,513
Latest member
junbuggle

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