查找特定值，刪除相應范圍。 宏異常緩慢

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