VBA代碼運行兩個循環非常慢

Question

我有這個代碼，它運行兩個循環後彼此。它可以正常工作幾千行。但隨着行數的增加，代碼運行時間會明顯延長。它應該循環超過100.000行，但這將需要數小時。 請讓我知道，如果你看到一個原因，這個代碼是需要這麼長時間

Sub BSIS() 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 


Dim lngRow As Long 
Dim counter As Long 

     'Merge rows with duplicate Cells 

With ActiveSheet 

.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 'change this to xlYes if your table has header cells 

    For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1 

    If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then 
     .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4) 
     .Rows(lngRow).Delete 
    End If 
    Next lngRow 

End With 

     'Delete rows with negative cells 


With ActiveSheet 

    For counter = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 

    If ActiveSheet.Cells(counter, 4) <= 0 Then 
     .Rows(counter).Delete 
    End If 

    Next counter 

End With 

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

Answer 1

原因慢跑是你刪除行逐一。

它總是更好的使用UNION功能

嘗試下面的代碼就應該努力做到在單發射擊，（測試）

Dim uni As Range 

With ActiveSheet 

    .Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 

    For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1 

     If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then 

      .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4) 
      If Not uni Is Nothing Then 
       Set uni = Application.Union(uni, Range(.Rows(lngRow).Address)) 
      Else 
       Set uni = Range(.Rows(lngRow).Address) 
      End If 

     End If 
    Next lngRow 

    uni.Delete 

End With 

Answer 2

一個辦法是複製你要檢查到一個數組數據的範圍。對該數組執行任何數據處理，然後將結果複製回Excel表單。這裏有一個例子：

Dim i As Integer 
Dim j As Integer 
Dim flagMatch As Boolean 
Dim arrData2Search As Variant 


Set arrData2Search = Range(Cells(1, 1), Cells(1000, 2000)).value 

flagMatch = False 
For j = 1 To 1000 
    For i = 1 To 2000 
     If arrData2Search (i, j)= "Target" Then 
      flagMatch = True 
     End If 
    Next i 
Next j 

Answer 3

有多種方式以優化個人VBA代碼的性能，並且大量的文章和論壇已經涵蓋了該主題。對於一個很好的資源，see this。

要記住的一個主要問題是，每次您的代碼與Excel的UI交互時，它都會比沒有發生交互時使用更多的開銷。這就是爲什麼（對於VBA編程人員來說）將數據加載到數組，執行計算並將數組寫回到工作表要快得多。這就是爲什麼（對Sathish而言），與每個人單獨（多次交互）相比，一次刪除所有行（一次交互）要快得多。有關刪除行的更多信息，請參閱see this。

關於您的代碼，是否有任何特殊原因需要兩個循環？

未經測試

Sub BSIS() 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim lngRow As Long 
Dim r As Range 

With ActiveSheet 
    .Cells(1).CurrentRegion.Sort key1:=.Cells(1), HEADER:=xlYes 'change this to xlYes if your table has header cells 
    'One loop: 
    For lngRow = .UsedRange.Rows.Count To 2 Step -1 

     'Merge rows with duplicate Cells 
     If .Cells(lngRow - 1, 1) = .Cells(lngRow, 1) Then 
      .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4) 
      If r Is Nothing Then 
       Set r = .Cells(lgnrow, 1) 
      Else: Set r = Union(r, .Cells(lgnrow, 1)) 
     End If 

     'Delete rows with negative cells 
     If .Cells(lngRow, 4) <= 0 Then 
      If r Is Nothing Then 
       Set r = .Cells(lngRow, 1) 
      Else: Set r = Union(r, .Cells(lgnrow, 1)) 
     End If 

    Next lngRow 
End With 

'Delete rows 
r.EntireRow.Delete 

Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub