刪除行時進程緩慢 - 如何使速度更快？

Question

我的工作簿中有幾個宏。這是唯一一個在2500排工作表上似乎很慢3-5分鐘的人。

目的是如果行在日期dtFrom和dtUpTo之間然後刪除整行。

我加入到暫停和恢復計算，提振稍微

人對如何使這個更快的任何想法？

Sub DeleteRows 
    '--- Pause Calculations: 
    Application.Calculation = xlManual 
    '----- DELETE ROWS ----- 
    Dim dtFrom As Date 
    Dim dtUpto As Date 
    Dim y As Long 
    Dim vCont As Variant 
    dtFrom = Sheets("Control Panel").Range("D5").Value 
    dtUpto = dtFrom + 6 
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..." 
    With Sheets("Database") 
     For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2 Step -1 
      vCont = .Cells(y, 1).Value 
      If Not IsError(vCont) Then 
       If vCont >= dtFrom And vCont <= dtUpto Then 
        .Rows(y).EntireRow.Delete 
       End If 
      End If 
     Next 
    End With 
    '--- Resume Calculations: 
    Application.Calculation = xlAutomatic 
    End Sub 

謝謝！

Answer 1

嘗試僅僅做對在結束所有相關行一次刪除操作：

Sub DeleteRows() 
'--- Pause Calculations: 
    Application.Calculation = xlManual 
    '----- DELETE ROWS ----- 
    Dim dtFrom    As Date 
    Dim dtUpto    As Date 
    Dim y      As Long 
    Dim vCont     As Variant 
    Dim rDelete As Range 
    dtFrom = Sheets("Control Panel").Range("D5").Value 
    dtUpto = dtFrom + 6 
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..." 
    With Sheets("Database") 
     For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2 Step -1 
      vCont = .Cells(y, 1).Value 
      If Not IsError(vCont) Then 
       If vCont >= dtFrom And vCont <= dtUpto Then 
        If rDelete Is Nothing Then 
         Set rDelete = .Rows(y) 
        Else 
         Set rDelete = Union(rDelete, .Rows(y)) 
        End If 
       End If 
      End If 
     Next 
    End With 
    If Not rDelete Is Nothing Then rDelete.EntireRow.Delete 
    '--- Resume Calculations: 
    Application.Calculation = xlAutomatic 
End Sub 

注意：您還可以在這裏使用一個自動篩選。

Answer 2

刪除大量的單獨行最好在一次操作中完成。 Rory已經演示了Union method創建一個不連續的行的集合，刪除一個Range.Delete操作。

雖然聯盟比方法通過個別行循環尋找要刪除的行要好得多，這仍然刪除（和移動）數據的不連續多行的CPU密集型操作受到影響。如果行可以方便地移動到一個塊中，則.Delete方法的運行速度會快得多。 A Range.Sort method看起來可能更多，但總體來說會更快。

Option Explicit 

Sub DeleteRows() 

    Dim dtFrom As Date 
    Dim dtUpto As Date 
    Dim y As Long 
    Dim d As Long, vDTs As Variant 

    'appTGGL bTGGL:=False '<~~ uncomment when finished debugging 

    dtFrom = Sheets("Control Panel").Range("D5").Value2 
    dtUpto = dtFrom + 6 
    Sheet1.Range("D1") = "Scanning, Please wait..." 

    'is this supposed to be Database or Sheet5? Are you mixing names and codenames? 
    With Worksheets("Database") 
     With .Cells(1, 1).CurrentRegion 
      With .Resize(.Rows.Count - 1, 1).Offset(1, 0) 
       vDTs = .Value2 
       For d = LBound(vDTs, 1) To UBound(vDTs, 1) 
        vDTs(d, 1) = IIf(vDTs(d, 1) >= dtFrom And vDTs(d, 1) <= dtUpto, 1, 0) 
       Next d 
      End With 
      With .Resize(.Rows.Count - 1, 1).Offset(1, .Columns.Count) 
       .Cells = vDTs 
      End With 
     End With 

     'reestablish the new currentregion 
     With .Cells(1, 1).CurrentRegion 
      .Cells.Sort key1:=.Columns(.Columns.Count), order1:=xlAscending, _ 
         Orientation:=xlTopToBottom, Header:=xlYes 
      d = Application.Match(1, .Columns(.Columns.Count), 0) 
      'one big block of rows to delete 
      .Cells(d, 1).Resize(.Rows.Count - d, 1).EntireRow.Delete 
      'done with the helper column 
      .Columns(.Columns.Count).EntireColumn.Delete 
     End With 

    End With 

    appTGGL 

End Sub 

Sub appTGGL(Optional bTGGL As Boolean = True) 
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) 
    Application.EnableEvents = bTGGL 
    Application.DisplayAlerts = bTGGL 
    Application.ScreenUpdating = bTGGL 
    Application.Cursor = IIf(bTGGL, xlDefault, xlWait) 
    Debug.Print Timer 
End Sub 

我通過測試此上50,000行（20×您正在處理的2500排片）放大的問題，只用了幾秒鐘。代碼看起來像是在做更多的工作，但它在創紀錄的時間內完成了任務。