Delete duplicate row in excel by comparing a column - vba

Question

Given below is an example of data i'm working with
As you can see it has duplicate entries.(actual database is 30000 entries)
I would like to find a method on how I can remove duplicate rows base on the corresponding column where percentage is listed.
The method should compare duplicate row percentages and choose the highest one and discard the other
This the question(initial):
I hope its clear with this output.
This is the result, I want
Any help would be appreciated!

Answer 1

Try this. It will (should) sort the data by the email and percentage column, then remove duplicates leaving the highest percentage intact.
With ActiveSheet
.Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Sort _
Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes, KEY2:=Range("B1"), Order2:=xlDescending, Header:=xlYes
.Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With

Answer 2

If you only need this method once you can do it manually.
Step 1: Sort by percentage descending.
Step 2: Use the 'Remove Duplicates' function on the data ribbon. Use it on the 'Email' column only.

Answer 3

1- clic DATA tab
2-select your data and clic Remove Duplicates
3-Select corresponding columns and clic OK.

Answer 4

Here is an altered version of the following post:
Delete all rows if duplicate in excel - VBA
Sub remDup2()
Dim rng As Range, dupRng As Range, lastrow As Long, ws As Worksheet
Dim col As Long, col2 As Long, offset As Long, deletecurrent As Boolean
'Disable all the stuff that is slowing down
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Define your worksheet here
Set ws = Worksheets(1)
'Define your column and row offset here
col = 1 'Column with E-Mail
col2 = 2 'Column with percentage
offset = 1 'Startrow with entries
'Find first empty row
Set rng = ws.Cells(offset + 1, col)
lastrow = rng.EntireColumn.Find( _
What:="", After:=ws.Cells(offset + 1, col)).Row - 1
'Loop through list
While (rng.Row < lastrow)
Do
Set dupRng = ws.Range(ws.Cells(rng.Row + 1, col), ws.Cells(lastrow, col)).Find( _
What:=rng, LookAt:=xlWhole)
If (Not (dupRng Is Nothing)) Then
If (ws.Cells(rng.Row, col2) > ws.Cells(dupRng.Row, col2)) Then
dupRng.EntireRow.Delete
lastrow = lastrow - 1
Else
deletecurrent = True
Exit Do
End If
If (lastrow = rng.Row) Then Exit Do
Else
Exit Do
End If
Loop
Set rng = rng.offset(1, 0)
'Delete current row
If (deletecurrent) Then
rng.offset(-1, 0).EntireRow.Delete
lastrow = lastrow - 1
End If
deletecurrent = False
Wend
'Enable stuff again
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub