查找特定值，删除对应范围。宏痛苦地慢

Question

在我的电子表格中，我有东西接近2000行。我需要搜索这些行，查找特定的日期（当前日期），然后删除相应的范围。但它运行非常缓慢。关于如何让它运行更快的任何建议？我在想，也许我可以根据日期组织我的行（当前日期将始终是最老的，因此位于顶部），然后使用范围（XX：XX“）删除所有行。但我不知道如何找到其中最后一行的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 

我throught约500行，与上面的代码匹配4分钟纪录的150个删除。我做了一个代码中断，因为没有人应该处理这个哈哈..

我的其他想法（下面）是更符合你的排序思路，这种方式只需要大约25秒做30500删除31500行。

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