Delete Double Entries

[dizzyfreedom]

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!!!

 

[Momentman]

Do you mean removing duplicates from Column G, i.e any row that has a duplicate mail in columnG should be deleted

 

[dizzyfreedom]

Yes. If there are two withthe same email on column G, I would need both rows deleted.

 

[konew1]

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]

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

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]

That would definitely work

You could also run this macro

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]

This might not be so efficient

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]

This might not be so efficient

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]

Hi dizzyfreedom,

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

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]

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

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