代码运行时间太长，有时会崩溃

您好，我有这个代码运行成功，但只有片刻之后。 有时甚至会停止响应，然后再次正常运行。需要帮助运行速度更快而不会崩溃。 这是代码

Sub DeleteCells() Dim R As Range 'Set rng = Nothing On Error Resume Next Set R = Application.InputBox("Select cells To be deleted", Type:=8) Dim rng As Range Dim rngError As Range Set rng = Sheets("Sheet3").Range("A1:G100") Set rngError = rng.Cells.SpecialCells(xlCellTypeFormulas, xlErrors) If TypeName(R) <> "Range" Then Exit Sub Else R.delete End If For Each cell In rng If cell.Text = "#REF!" Then cell.EntireColumn.delete End If 'delete means cells will move up after deleting that entire row 'rngError.EntireRow.ClearContents means that the contents will clear, leaving a blank cell for that entire row Next End Sub 

Answer 1

您正在删除循环中的单元格，这可能会使其变得非常慢。 这是你正在尝试？ 这应该是非常快的…（ 未经testing ）

 Sub DeleteCells() Dim rng As Range, rngError As Range, delRange As Range Dim i As Long, j As Long On Error Resume Next Set rng = Application.InputBox("Select cells To be deleted", Type:=8) On Error GoTo 0 If rng Is Nothing Then Exit Sub Else rng.Delete With Sheets("Sheet3") For i = 1 To 7 '<~~ Loop trough columns A to G '~~> Check if that column has any errors On Error Resume Next Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors) On Error GoTo 0 If Not rngError Is Nothing Then For j = 1 To 100 '<~~ Loop Through rows 1 to 100 If .Cells(j, i).Text = "#REF!" Then '~~> Store The range to be deleted If delRange Is Nothing Then Set delRange = .Columns(i) Exit For Else Set delRange = Union(delRange, .Columns(i)) End If End If Next End If Next End With '~~> Delete the range in one go If Not delRange Is Nothing Then delRange.Delete End Sub