Removing duplicate on priority criteria

Can you post up a 15-20 row example data set showing before/after, just so it's perfectly clear?

Click GO ADVANCED and use the paperclip icon to post up a desensitized copy of your workbook.

This should do it.

Option Explicit

Sub RemoveNonpriorityEmailDuplicates()
'Author:    Jerry Beaucaire
'Date:      6/20/2010
'Summary:   Removes duplicate email addresses keeping one
'           using the following priority list:
'           ebay > amazon > bestbuy > wallmart > target

Dim Rw      As Long
Dim LR      As Long
Dim KeyCol  As Long
Dim DelRng  As Range

'solve variables
    LR = Range("A" & Rows.Count).End(xlUp).Row
    KeyCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
'seed the delete rng
    Set DelRng = Range("A" & LR + 10)
    
'add ordering formula in empty column
    Range(Cells(2, KeyCol), Cells(LR, KeyCol)).FormulaR1C1 = _
        "=MATCH(RC1,{""ebay"",""amazon"",""bestbuy"",""wallmart"",""target""},0)"

'sort by email address and ordering key column
    Range("A1", Cells(LR, KeyCol)).Sort Key1:=Range("B2"), Order1:=xlAscending, _
        Key2:=Cells(2, KeyCol), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
        DataOption2:=xlSortNormal
    
'Loop to note all rows that are not the top priority in duplicate rows
    For Rw = 3 To LR
        If Range("B" & Rw) = Range("B" & Rw - 1) Then _
            Set DelRng = Union(DelRng, Range("A" & Rw))
    Next Rw

'delete non-priority duplicates all at once, cleanup
    DelRng.EntireRow.Delete xlShiftUp
    Set DelRng = Nothing
    Columns(KeyCol).ClearContents
End Sub

To do this quickly and easily I sorted all the rows together. Why would the order change be problematic?

Anyway, try this, it will only clear email addresses (not rows) and the rows will be in their original order at the end.

Option Explicit

Sub RemoveNonpriorityEmailDuplicates()
'Author:    Jerry Beaucaire
'Date:      6/20/2010
'Summary:   Removes duplicate email addresses keeping one
'           using the following priority list:
'           ebay > amazon > bestbuy > wallmart > target

Dim Rw      As Long
Dim LR      As Long
Dim KeyCol  As Long
Dim DelRng  As Range

'solve variables
    LR = Range("A" & Rows.Count).End(xlUp).Row
    KeyCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
'seed the delete rng
    Set DelRng = Range("A" & LR + 10)
    
'add ordering formula in empty column
    Range(Cells(2, KeyCol), Cells(LR, KeyCol)).FormulaR1C1 = _
        "=MATCH(RC1,{""ebay"",""amazon"",""bestbuy"",""wallmart"",""target""},0)"
    With Range(Cells(2, KeyCol + 1), Cells(LR, KeyCol + 1))
        .FormulaR1C1 = "=N(R[-1]C) + 1"
        .Value = .Value
    End With
    
'sort by email address and ordering key column
    Range("A1", Cells(LR, KeyCol + 1)).Sort Key1:=Range("B2"), Order1:=xlAscending, _
        Key2:=Cells(2, KeyCol), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
        DataOption2:=xlSortNormal
    
'Loop to note all rows that are not the top priority in duplicate rows
    For Rw = 3 To LR
        If Range("B" & Rw) = Range("B" & Rw - 1) Then _
            Set DelRng = Union(DelRng, Range("B" & Rw))
    Next Rw

'delete non-priority duplicates all at once
    DelRng.ClearContents
    Set DelRng = Nothing
    
'sort by back to original order, cleanup
    Range("A1", Cells(LR, KeyCol + 1)).Sort Key1:=Cells(2, KeyCol + 1), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
Columns(KeyCol).Resize(, 2).ClearContents
End Sub