VBA根据一组date删除X个数据实例

我有一个独特的情况没有涵盖在其他文章，我可以在这里find。 我有一个成千上万行的工作簿，但他们都基本上是这样的：

工作簿中有很多“东西”，数据不断被添加，但问题的关键是我需要一段代码才能保留一定数量的最新数据实例（让我们说2），并删除其余的。 我不经常在VBA中处理date，所以我希望能够“展示我的工作”，但是我真的不知道从哪里开始。

用简单的英语：计算D列中唯一date的数量。如果该数字大于2，则删除date比最近2个date早的行。

再次，我很抱歉没有任何工作显示到目前为止。 我真的有“作家阻挡”这一个。 任何帮助表示赞赏！

更新：在我已经写了以下注释的帮助来做我的真正的数据表（35000+行），其中date列是P的第二个最近的date的第一步，我一定是做错了什么，因为因为我跟踪OldMax在本地窗口中的值，无论我在Large(DateRange,whatever number)它都只返回最近的date。 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

我testing了下面的代码，它的工作原理。 应该相当容易理解，但我基本上只是循环遍历所有的行，以确定最近的两个date是什么，然后再遍历所有的行，删除任何不包含任何这些date的行。

 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 

Answer 2

我结束了使用以下，因为我只使用“保留2最近date”作为一个简单的例子。 我实际上保留了12个最近的date，所以其他提出的答案会非常麻烦。 这是我想出来的。

 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