缓慢删除行的过程 – 如何使速度更快？

我的工作簿中有几个macros。 这是唯一一个在2500张纸上3-5分钟真的很慢的纸张。

目的是如果Row在datedtFrom和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 

注意：您也可以在这里使用自动filter。

Answer 2

删除大量的单个行最好在一个操作中完成。 Rory已经演示了使用一个Range.Delete操作创build不连续行的集合的联合方法 。

虽然联合方法好于循环查找要删除的行的单个行，但是仍然存在删除（和移动）许多不连续的数据行的CPU密集型操作。 如果行可以方便地移入一个块，那么.Delete方法将工作得更快。 Range.Sort方法可能看起来像更多的工作，但总体上会更快。

 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 

我放大了这个问题，通过testing50,000行（20×2500行的表单），这只需要几秒钟。 代码看起来像是在做更多的工作，但是它能够在创纪录的时间内完成任务。