查找特定值，删除相应范围。 宏异常缓慢

Question

在我的电子表格中，我有近2,000行。 我需要搜索这些行，找到一个特定的日期（当前日期），然后删除一个相应的范围。 但是它运行非常非常缓慢。 关于如何使其运行更快的任何建议？ 我在想，也许我可以根据日期来组织行（当前日期将始终是最旧的，因此位于顶部），然后使用Range（XX：XX“）。Delete一次删除所有行。但是我不知道如何找到Currentdate的最后一行，因为它将不断变化。

Sub ChangeandDelete
 MudaDataLCA
 DeleteDateLCA
End Sub

Sub MudaDataLCA()
'===Muda Data Atual ABERTURA===
Dim Affected As Workbook
Dim Dados As Worksheet
Dim LastRow As Long


Set Affected = Workbooks("Controle de Lastro LCA_FEC - Test")
Set Dados = Affected.Sheets("DADOS")
Dados.Activate
    Dim CurrentDate As Date
    CurrentDate = Range("AH2") + 1
    Range("AH2") = CurrentDate


End Sub
Sub DeleteDateLCA()
Dim Affected As Workbook
Dim Dados As Worksheet
Dim LastRow As Long

Set Affected = Workbooks("Controle de Lastro LCA_FEC - Test")
Set Dados = Affected.Sheets("DADOS")
Dados.Activate

LastRow = Dados.Cells(Rows.Count, "P").End(xlUp).Row
    For i = 5 To LastRow
        Do While Range("S" & i).Value = Range("AH2")
        Range("P" & i & ":AG" & i).Delete
        Loop
    Next i

End Sub

Answer 1

这种对AH2中更新日期进行过滤的方法应大大加快该过程。

Sub ChangeandDelete()
    Dim fr As Long, lr As Long, fString As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    With Workbooks("Controle de Lastro LCA_FEC - Test").Sheets("DADOS")
        .Range("AH2") = CDate(.Range("AH2").Value + 1)
        fr = 4: lr = .Cells(Rows.Count, "P").End(xlUp).Row
        fString = Chr(61) & Format(.Range("AH2").Value, .Range("P5").NumberFormat)
        With .Range(.Cells(fr, "P"), .Cells(lr, "P"))
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=fString
            If CBool(Application.Subtotal(102, .Columns(1)) + IsNumeric(.Cells(1, 1).Value2)) Then
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    .SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
                Debug.Print Application.Count(.Columns(1))
            End If
            .AutoFilter
        End With
    End With
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

我已经假设，至少每当删除一行后，减速的一部分就是公式重新计算，这将表明是自动计算。 我已关闭自动计算，并在处理完成后将其还原。 还有其他方法可以存储工作簿/工作表计算的当前状态，关闭计算，然后恢复原始状态。

Answer 2

所以我有两个答案。 我输入了39000行数据，并使用了满足删除条件的7500行数据-因此我可以测试时间（64位Windows 7）

循环可能会非常慢，但我将首先编写它，因为它与您的代码最接近：

Sub DeleteIT()

Dim deleteRange As Range
Dim deleteValue As Date
Dim lastRow As Long

Set affected = ThisWorkbook
Set dados = affected.Sheets("DADOS")

Dim CTtimer As CTimer
'Set CTtimer = New CTimer
'Dados.Activate
    Application.ScreenUpdating = False

deleteValue = dados.Range("AH2")
lastRow = dados.Range("S" & dados.Rows.Count).End(xlUp).Row
 'CTtimer.StartCounter
    Do
        Set deleteRange = Range("S5:S" & lastRow).Find(what:=deleteValue, LookIn:=xlValues, _
            lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        If Not deleteRange Is Nothing Then deleteRange.Range(Cells(1, 1), Cells(1, 18)).Offset(0, -3).Delete
    Loop While Not deleteRange Is Nothing
'MsgBox CTtimer.TimeElapsed

Application.ScreenUpdating = True

End Sub

使用上述代码，我在4分钟内获得了大约500行和150条匹配记录的删除。 我做了一个代码中断，然后停止了，因为没有人应该去处理那个哈哈。

我的另一个想法（如下）更像是您的排序想法，这种方式仅花费了大约25秒的时间就从31500行中删除了30500个。

Sub aReader()
Dim affected As Workbook
Dim SheetName As String
Dim deleteValue As Date
Dim population As Range
Dim lastRow As Long
Dim x As Long
'Dim CTtimer As CTimer
'Set CTtimer = New CTimer
Set affected = ThisWorkbook

Application.ScreenUpdating = False

SheetName = "DADOS"

deleteValue = affected.Worksheets(SheetName).Range("AH2")

Set population = Worksheets(SheetName).Range("P5", Sheets(SheetName).Range("P5").End(xlDown))
'CTtimer.StartCounter

For x = 1 To population.Count

    If population.Cells(x, 4).Value = deleteValue Then Range(population.Cells(x, 1), population.Cells(x, 18)).Value = ""

Next x

Range("P5:AG" & (population.Count + 4)).Sort key1:=Range("S5:S" & population.Count + 4), _
   order1:=xlAscending, Header:=xlNo

Application.ScreenUpdating = True
'MsgBox CTtimer.TimeElapsed
End Sub