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

VBA代码运行两个循环非常慢

3 个答案: