VBA для удаления X экземпляров данных на основе набора дат

Question

У меня есть уникальная ситуация, не охваченная другой статьей, которую я могу найти здесь. У меня есть книги из десятков тысяч строк, но все они в основном так:

Там целая много «материала» происходит в книге и данных постоянно пополняется, но Суть моей проблемы в том, что мне нужна часть кода, чтобы иметь возможность хранить определенное количество последних экземпляров данных (скажем 2) и удалять остальные. Я не часто встречаюсь с датами в VBA, поэтому мне хотелось бы «показать свою работу» до сих пор, но я действительно не знаю, с чего начать.

Простым английским: подсчитайте количество уникальных дат в столбце D. Если это число> 2, THEN удалите строки, в которых дата старше, чем две последние даты.

Опять же, прошу прощения за то, что у меня пока нет работы. У меня действительно есть «блок писателей» на этом. Любая помощь приветствуется!

ОБНОВЛЕНИЕ: С помощью комментариев я написал следующее, чтобы сделать первый шаг, чтобы найти вторую самую последнюю дату в моей реальной спецификации (35000+ строк), где столбец даты - P. Я должен быть что-то не так, потому что, когда я отслеживаю значение OldMax в окне locals, он возвращает только самую последнюю дату, независимо от того, что я ввел для числа в Large(DateRange,whatever number). Hmmmmm ....

 Sub Remove_Old_Data() 

    Dim wks As Worksheet 
    Dim OldMax As String 
    Dim DateRange As Range 
    Dim lrow As Long 

    Set wks = ThisWorkbook.Worksheets("X-AotA") 
    lrow = wks.Cells(Rows.Count, "P").End(xlUp).Row 
    Set DateRange = wks.Range("P2:P" & lrow) 

    OldMax = Application.WorksheetFunction.Large(DateRange, 2) 

    End Sub 

Answer 1

В итоге я использовал следующее, потому что использовал только «сохранить 2 последних даты» в качестве упрощенного примера. Я фактически сохраняю 12 самых последних дат, поэтому другой предложенный ответ будет довольно громоздким. Вот что я придумал.

Sub Scrub_Old_Data() 

Dim iUnique As Long 
Dim Wks As Worksheet 
Dim LastRow As Long 
Dim i As Long 
Dim OldDateKeep As Long 

OldDateKeep = ThisWorkbook.Worksheets("X-User Input").Range("B11").Value 

Set Wks = ThisWorkbook.Worksheets("X-AotA") 

'find the last row of data 
LastRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row 

'make sure the right worksheet is being analyzed 
Wks.Select 

'check the entire sheet to see if we even have more than 12 unique dates. If not, do nothing 
iUnique = Evaluate("=SUMPRODUCT(1/countif(P2:P" & LastRow & ",P2:P" & LastRow & "))") 

If iUnique > OldDateKeep Then 

    With Wks 
     'sort in descending date order 
     .AutoFilter.Sort.SortFields.Clear 

     .AutoFilter.Sort.SortFields. _ 
      Add Key:=Range("P1:P" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, _ 
     DataOption:=xlSortNormal 

     With .AutoFilter.Sort 
      .Header = xlYes 
      .MatchCase = False 
      .Orientation = xlTopToBottom 
      .SortMethod = xlPinYin 
      .Apply 
     End With 

    End With 

    i = 2 
    Do Until IsEmpty(Cells(i, 16)) 

     If Evaluate("=SUMPRODUCT(1/countif(P1:P" & i & ",P1:P" & i & "))") - 1 > OldDateKeep Then 

      Cells(i, 16).EntireRow.Delete 

     Else 

      i = i + 1 

     End If 

    Loop 


End If 


End Sub 

Answer 2

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

Sub Remove_Old_Data() 

    On Error GoTo 0 

    Dim vSheet As Worksheet 
    Dim vRange As Range 
    Dim vRow As Long 
    Dim vRowFirst As Long 
    Dim vRowLast As Long 
    Dim vCol As Long 
    Dim vCurDate As Date 
    Dim vTopDate1 As Date 
    Dim vTopDate2 As Date 

    Set vSheet = ThisWorkbook.Worksheets("X-AotA") 
    Set vRange = vSheet.UsedRange 

    'Set vCol to column P 
    vCol = 17 - vRange.Column 

    'Set the rows to scan through 
    vRowFirst = 2 
    vRowLast = vRange.Rows.Count 
    If vRowLast < 4 Then Exit Sub 

    'Determine what the biggest 2 dates are 
    vTopDate1 = DateValue("1900-01-01") 
    vTopDate2 = DateValue("1900-01-01") 
    For vRow = vRowFirst To vRowLast 
     vCurDate = DateValue("1900-01-01") 
     On Error Resume Next 
     vCurDate = DateValue(vRange(vRow, vCol).Value) 
     On Error GoTo 0 

     If vCurDate > vTopDate1 Then 
      vTopDate2 = vTopDate1 
      vTopDate1 = vCurDate 
     ElseIf vCurDate > vTopDate2 And vCurDate <> vTopDate1 Then 
      vTopDate2 = vCurDate 
     End If 
    Next 

    'Loop through the rows again and remove any that do not contain the top 2 dates 
    vRow = vRowFirst 
    Do While vRow <= vRowLast 
     vCurDate = DateValue("1900-01-01") 
     On Error Resume Next 
     vCurDate = DateValue(vRange(vRow, vCol).Value) 
     On Error GoTo 0 

     If vCurDate <> vTopDate1 And vCurDate <> vTopDate2 Then 
      'Remove this row 
      vRange.Cells(vRow, 1).EntireRow.Delete 
      vRowLast = vRowLast - 1 
     Else 
      'Continue to the next row 
      vRow = vRow + 1 
     End If 
    Loop 

End Sub