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

Question

I have this code which runs two loops after each other. It works fine for a few thousand rows. But as the number of rows increases, the code runs significantly longer. It should loop over 100.000 rows but this will take hours and hours. Please let me know if you see a reason why this code is taking so long

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

one option would be copying the range of data you want to examine into an array. Do what ever data processing you want with that array, then copy the results back into the excel sheet. Here is an example:

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

The reason for slow run is that you are deleting rows one by one .

It always better to do it in single shot using UNION function

Try the below code it should work,(Tested)

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

There are a number of ways to optimize performance of one's VBA code, and a good number of articles and forums have covered the topic. For a great resource, see this .

One of the main things to remember is that every time your code interacts with the UI of Excel, it uses much more overhead than if the interaction had not occurred. That's why (to VBA Programmer's point) it's much faster to load the data to an array, perform your calculations, and then write the array back to a sheet. And that's why (to Sathish's point) it's much faster to delete all the rows at once (one interaction) compared to each one individually (multiple interactions). For more information about deleting rows, see this .

With regards to your code, is there any particular reason you need two loops?

Untested

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