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

一種選擇是將要檢查的數據范圍復制到數組中。 使用該數組進行所需的數據處理，然后將結果復制回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 2

運行緩慢的原因是要逐行刪除行 。

使用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 3

有很多方法可以優化一個人的VBA代碼的性能，並且有很多文章和論壇都介紹了該主題。 要獲取大量資源， 請參見this 。

要記住的主要事情之一是，每次您的代碼與Excel的UI進行交互時，與未進行交互時相比，它會消耗更多的開銷。 這就是為什么（就VBA程序員而言）將數據加載到數組，執行計算然后將數組寫回到工作表要快得多。 這就是為什么（就Sathish而言），一次刪除所有行（一次交互）要比單獨刪除每行（多次交互）要快得多。 有關刪除行的更多信息， 請參見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