Удалите повторяющиеся строки, но сохраните всю строку с наивысшим значением в определенной ячейке

Question

У меня есть лист excel с 17 столбцами (столбец А до столбца S). Столбец A содержит идентификационные номера, столбец C является столбцом даты, а столбец F содержит значения во временном формате (hh: mm). Для той же даты/дня некоторые идентификационные номера содержат два значения в столбце F - обычно большое число (много часов и мин) и небольшое количество (несколько минут). Если такой дубликат, я хочу, чтобы вся строка, содержащая низкое значение в столбце F, удалялась из листа.

Я попытался с помощью «onboard» Excel удалить дубликаты-функции, но это не помогло. Потом я наткнулся на этот кусок VBA код, который удаляет все повторяющиеся строки, которые содержат наибольшее значение:

Option Explicit 

Sub RemoveDuplicatesKeepMin() 
    Dim r As Integer, r2 As Integer, i As Integer 
    Dim rng As Range 
    Dim NextVal As Double 

    r = Range("A" & Rows.Count).End(xlUp).Row 
    Set rng = Range("A2:C" & r) 
    rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _ 
     , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ 
     False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ 
     :=xlSortNormal 

    r2 = 2 
    For i = 2 To r 
     If Not NextVal = Range("A" & i) Then 
      Range(Cells(i, 1), Cells(i, 2)).Copy Destination:=Range("D" & r2) 
     r2 = r2 + 1 
     NextVal = Range("A" & i + 1) 
    End If 
Next 
rng.Delete Shift:=xlShiftToLeft 
Set rng = Nothing 
End Sub 

Я не совсем уверен, что понимаю логику, но я предполагаю, что это может быть использовано в качестве отправной точки (реверсирование логики и добавление нового ограничения (если в тот же день) .Если я изменю заказы от восходящего к нисходящему, это займет наивысшее значение. Но я не уверен, как добавить дополнительные ограничение (ограничение день) в

Thx

Answer 1

Здесь мой подход к вашей проблеме:.!

Public Sub deleteDuplicate() 

    Dim row As Integer 

    'Set the start row 
    row = 2 

    With Sheets("sheetname") 

     'Loop until ID cell is blank 
     Do While .Range("A" & row) <> "" 

      innerRow = 1 

      'Re-loop until ID cell is blank for checking 
      Do While .Range("A" & innerRow) <> "" 

       'If ID and date are equal 
       If row <> innerRow And .Range("A" & row) = .Range("A" & innerRow) And .Range("C" & row) = .Range("C" & innerRow) Then 

        If .Range("F" & row) < .Range("F" & innerRow) Then 

         .Rows(row).Delete 

         row = row - 1 

         Exit Do 

        Else 

         .Rows(innerRow).Delete 

        End If 

       End If 

       'Increase inner looping row 
       innerRow = innerRow + 1 

      Loop 

      'Increase row 
      row = row + 1 

     Loop 

    End With 

End Sub