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 代码的性能，很多文章和论坛都涵盖了这个主题。如需优质资源，请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