VBA代码需要很长时间才能执行
以下VBA代码需要很长时间才能执行。 我25分钟前跑了48000行，它仍然在运行。 我怎样才能缩短执行时间？
Sub delrows() Dim r, RowCount As Long r = 2 ActiveSheet.Columns(1).Select RowCount = UsedRange.Rows.Count userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info") Rows(RowCount).Delete Shift:=xlUp ' Trim spaces Columns("A:A").Select Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _ ReplaceFormat:=False ' Delete surplus columns Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select Selection.Delete Shift:=xlToLeft ' Delete surplus rows Do If Left(Cells(r, 1), 1) = "D" _ Or Left(Cells(r, 1), 1) = "H" _ Or Left(Cells(r, 1), 1) = "I" _ Or Left(Cells(r, 1), 2) = "MD" _ Or Left(Cells(r, 1), 2) = "ND" _ Or Left(Cells(r, 1), 3) = "MSF" _ Or Left(Cells(r, 1), 5) = "MSGZZ" _ Or Len(Cells(r, 1)) = 5 _ Or Cells(r, 3) = 0 Then Rows(r).Delete Shift:=xlUp ElseIf Int(Right(Cells(r, 1), 4)) > 4000 Then Rows(r).Delete Shift:=xlUp Else: r = r + 1 End If Loop Until (r = RowCount) End Sub 最大的问题可能是你正在循环的数据量。 我更新了代码来创build一个公式来检查行是否需要删除，然后您可以过滤该公式结果并一次删除所有行。
我已经做了一堆评论，以帮助您清理您的代码，并了解我做了什么。 我以'=>开始了我的评论。
最后一点，将值加载到数组中可能也有帮助，但是如果有许多列的数据，这可能会更困难。 我没有很多的经验，但是我知道它让世界变得更快！
祝好运并玩得开心点！
Option Explicit Sub delrows() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim r As Long, RowCount As Long r = 2 Dim wks As Worksheet Set wks = Sheets(1) '=> change to whatever sheet index (or name) you want '=> rarely a need to select anything in VBA [ActiveSheet.Columns(1).Select] With wks RowCount = .Range("A" & .Rows.Count).End(xlUp).Row '=> as opposed to [RowCount = UsedRange.Rows.Count], as UsedRange can be misleading 'NOTE: this also assumes Col A will have your last data row, can move to another column userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info") .Rows(RowCount).Delete Shift:=xlUp ' Trim spaces '=> rarely a need to select anything in VBA [Columns("A:A").Select] .Range("A1:A" & RowCount).Replace What:=" ", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _ ReplaceFormat:=False ' Delete surplus columns '=> rarely a need to select anything in VBA [Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select] .Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Delete Shift:=xlToLeft ' as opposed to Selection.Delete Shift:=xlToLeft ' Delete surplus rows '=> Now, here is where we help you loop: '=> First insert column to the right to capture your data .Columns(1).Insert Shift:=xlToRight .Range("A1:A" & RowCount).FormulaR1C1 = "=If(OR(Left(RC[1],1) = ""D"",Left(RC[1],1) = ""H"", Left(RC[1],1) = ""I"", Left(RC[1],2) = ""MD"",Left(RC[1],2) = ""ND"",Left(RC[1],3) = ""MSF"",Left(RC[1],5) = ""MSGZZ"",Len(RC[1])=5),""DELETE"",If(Int(Right(RC[1],4)) > 4000,""DELETE"",""""),""""))" '=> Now, assuming you something to delete ... If Not .Columns(1).Find("DELETE", LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then '=> filter and delete .Range("A1:A" & RowCount).AutoFilter 1, "DELETE" Intersect(.UsedRange, .UsedRange.Offset(1), .Range("A1:A" & RowCount)).SpecialCells(xlCellTypeVisible).EntireRow.Delete End If '=> Get rid of formula column .Columns(1).EntireColumn.Delete End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub
这么慢的原因是你迭代每个单元格。 下面复制到一个数组，find需要删除的行然后删除。 将Sheet4更新到您的工作表和范围（“A2”）。CurrentRegion到您需要的区域：
Dim data() As Variant Dim count As Double, i As Double, z As Double, arrayCount As Double Dim deleteRowsFinal As Range Dim deleteRows() As Double Application.ScreenUpdating = False data = Sheet4.Range("A2").CurrentRegion.Value2 For i = 1 To UBound(data, 1) count = count + 1 If (data(i, 1) = "D" Or Left(data(i, 1), 1) = "H" Or Left(data(i, 1), 1) = "I" Or Left(data(i, 1), 2) = "MD" _ Or Left(data(i, 1), 2) = "ND" Or Left(data(i, 1), 3) = "MSF" Or Left(data(i, 1), 5) = "MSGZZ" _ Or Len(data(i, 1)) = 5 Or data(i, 3) = 0 Or Int(Right(IIf(Cells(i, 1) = vbNullString, 0, Cells(i, 1)), 4)) > 4000) Then ReDim Preserve deleteRows(arrayCount) deleteRows(UBound(deleteRows)) = count arrayCount = arrayCount + 1 End If Next i Set deleteRowsFinal = Sheet4.Rows(deleteRows(0)) For z = 1 To UBound(deleteRows) Set deleteRowsFinal = Union(deleteRowsFinal, Sheet4.Rows(deleteRows(z))) Next z deleteRowsFinal.Delete Shift:=xlUp Application.ScreenUpdating = True
closures屏幕更新以开始。 在下面添加你的意见。
如果你认为它不影响任何事情，你也可以禁用计算。
Application.ScreenUpdating = False your code... Application.ScreenUpdating = True
编辑：我上传了一个文件在这里 – https://dl.dropbox.com/u/24702181/TestDeleteRowsInChunk.xls
工作簿已启用macros。
打开后，点击“恢复数据”，然后点击“开始删除”。
看看代码的细节。 我想它可以进一步优化。
几个提示
- 做一个反向循环。
- 获取数组中的单元格内容，使用数组检查值。
- 为要删除的行构build一个string。
- 将其以大块方式删除。