代碼運行時間太長，最終崩潰時間

Question

嗨，我有這個代碼運行成功，但只有一段時間後。有時它甚至會停止響應，然後再次正常運行。需要幫助它更快地運行而不會崩潰。這裏是代碼

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

您正在刪除一個循環中的單元格，使其變得非常慢。這是你正在嘗試的嗎？這應該是非常快的...（未測試）

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