Delete Duplicate rows with duplicate in 1 column based on value from another column

Hi CraigR&M,

Here is code that I think does what you describe. Out of any duplicates, the value with the highest corresponding value in Column F is kept.

Sub DeleteDuplicates()

' Define Variables
Dim i As Long
Dim j As Long
Dim k As Long
Dim vMatch As Variant
Dim LastRow As Long

' Suppress Error Notification
On Error Resume Next
Err.Clear

' Check Duplicates
k = 2
100 ' Loop from here
LastRow = Range("A" & Rows.Count).End(xlUp).Row

' Determine if data has been completely processed
If (LastRow <= k) Then
   Application.StatusBar = "Process Complete..."
   Application.Wait (Now + TimeValue("00:00:02"))
   GoTo 10000
End If
' Check for duplicates and delete row with lowest value in Column F
For i = k To LastRow
   Application.StatusBar = "Checking line " & i & " of " & LastRow & "..."
   j = i + 1
   vMatch = WorksheetFunction.Match(Range("A" & i), Range(Cells(j, 1), Cells(LastRow, 1)), 0)
   If (Err.Number = 0) Then
      If (Range("F" & i) < Range("F" & i + vMatch)) Then
         Rows(i).Delete shift:=xlUp
      Else
         Rows(i + vMatch).Delete shift:=xlUp
      End If
      k = i
      GoTo 100
   Else
      Err.Clear
   End If
Next i

10000 ' Clear Status Bar and Enable Error Notification
Application.StatusBar = ""
On Error GoTo 0

End Sub

Hope that helps,

Dan

*** Double post deleted ***

Sub Deletesies()
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.StatusBar = "Finding Minimum Values"
Dim cell As Range
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("I2:I" & LR)
    .FormulaR1C1 = "=MIN(IF(R2C1:R" & LR & "C1=R[0]C[-8],R2C6:R" & LR & "C6))"
    .FormulaArray = .FormulaR1C1
    .Value = .Value
End With
For i = LR To 2 Step -1
    If Cells(i, 6) <> Cells(i, 9) Then
        Cells(i, 1).EntireRow.Delete
    Else
        If Not dict.exists(Cells(i, 1).Value) Then
            dict.Add Cells(i, 1).Value, 0
        Else
            Cells(i, 1).EntireRow.Delete
        End If
    End If
    Cells(i, 9).Clear
    Application.StatusBar = Format((LR - i) / LR, "Percent") & " Row Removal Complete"
Next
Set dict = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub