Question

我有一个独特的情况，我在这里找不到其他文章。我有一本成千上万行的工作簿，但他们基本上都是这样的：

enter image description here

有很多＆＃34;东西＆＃34;继续添加工作簿和数据，但我的问题的关键是我需要一段代码才能保留一定数量的最新数据实例（让我们说2）并删除其余的。我不经常在VBA处理日期，所以我希望我可以“展示我的作品”＃34;到目前为止，但我真的不知道从哪里开始。

简单英语：计算D栏中唯一日期的数量。如果该数字是＆gt; 2，那么删除日期早于2个最近日期的行。

再次，我为迄今为止没有任何工作表示歉意。我真的有＆＃34;作家＆＃39;块＆＃34;在这一个。任何帮助表示赞赏！

更新：在评论的帮助下，我已经写了以下内容，以便在我的真实数据表（35000+行）中找到第二个最近日期的第一步，其中日期列为P.我必须做错了，因为当我在本地窗口中跟踪OldMax的值时，无论我为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个日期，然后再遍历所有行，删除任何不包含这些日期的行。

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个最近日期”作为简化示例。我实际上保留了最近的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

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

2 个答案: