VBA代码运行两个循环非常慢 [英] VBA code runs two loops very slow

问题描述

我有这个代码运行两个循环之后。它工作正常几千行。但随着行数的增加，代码运行时间明显更长。它应该循环超过100.000行，但这将需要几个小时。
如果您看到此代码花费了这么长时间的原因，请让我知道

  Sub BSIS（）
 
 Application.ScreenUpdating = False 
 Application.Calculation = xlCalculationManual 
 
 
 Dim lngRow As Long 
 Dim counter As Long 
 
'合并具有重复单元格的行
 
使用ActiveSheet 
 
 .Cells（1）.CurrentRegion.Sort key1：=。Cells（1），Header：= xlYes'change如果你的表具有标题单元格
 
对于lngRow = ActiveSheet.UsedRange.Rows.Count到2 Step -1 
 
如果ActiveSheet.Cells（lngRow  -  1，1） ）= ActiveSheet.Cells（lngRow，1）然后
 .Cells（lngRow  -  1,4）= .Cells（lngRow  -  1，4）+ .Cells（lngRow，4）
 .Rows（lngRow ）。删除
结束如果
下一个lngRow 
 
结束
 
'删除带有单元格的行
 
 
 ActiveSheet 
 
对于counter = ActiveSheet.UsedRange.Rows.Count到1 Step -1 
 
如果ActiveSheet.Ce lls（counter，4）< = 0然后
 .Rows（counter）.Delete 
 End If 
 
下一个计数器
 
结束
 
 Application.Calculation = xlCalculationAutomatic 
 Application.ScreenUpdating = True 
 
 End Sub 
  

解决方案

缓慢运行的原因是您逐个删除行。

最好使用 UNION 功能

尝试以下代码，它应该工作，（测试）

  Dim uni As Range 
 
 With ActiveSheet 
 
 .Cells（1）.CurrentRegion。排序key1：=。单元格（1），标题：= xlYes 
 
对于lngRow = ActiveSheet.UsedRange.Rows.Count到2步骤-1 
 
如果ActiveSheet.Cells（ lngRow  -  1，1）= ActiveSheet.Cells（lngRow，1）然后
 
 .Cells（l ngRow  -  1，4）= .Cells（lngRow  -  1,4）+ .Cells（lngRow，4）
如果不是uni Is Nothing然后
设置uni = Application.Union（uni，Range（。 Rows（lngRow）.Address））
 Else 
 Set uni = Range（.Rows（lngRow）.Address）
 End If 
 
 End If 
下一页lngRow 
 
 uni.Delete 
 
结束
  

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

解决方案

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

这篇关于VBA代码运行两个循环非常慢的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！