VBA脚本导致Excel在15个循环后无法响应 [英] VBA script causes Excel to not respond after 15 loops

问题描述

我正在运行一个脚本，以查找和删除包含2018年之后的数据的行.我正在搜索约650000行.每次5秒钟后运行脚本时，光标都会变成旋转的圆圈，而excel程序将变得无响应.这是我正在使用的代码.

I am running a script to find and delete rows that contain data from after 2018. I am searching through around 650000 rows. Every time I run the script after 5 seconds my cursor becomes the spinning circle and the excel program becomes unresponsive. Here is the code I am using.

Option Explicit
Option Base 1 'row and column index will match array index

Sub removeWrongYear()

Dim i As Long, yearA As Long, rowsCnt As Long
Dim rowsToDelete As Range
Dim vData As Variant

With ActiveSheet

    '1st to 635475 row, 20th column
    vData = Range(.Cells(1, 20), .Cells(635475, 20))

    For i = UBound(vData) To 2 Step -1
       If Val(Right(vData(i,1),2)) > 17 Then
        Debug.Print Val(Right(vData(i,1),2))
            rowsCnt = rowsCnt + 1

            If rowsCnt > 1 Then
                Set rowsToDelete = Union(rowsToDelete, .Rows(i))
            ElseIf rowsCnt = 1 Then
                Set rowsToDelete = .Rows(i)
            End If

        End If
    Next i

End With

If rowsCnt > 0 Then
    Application.ScreenUpdating = False
    rowsToDelete.EntireRow.Delete
    Application.ScreenUpdating = True
End If

End Sub

推荐答案

此方法使用AutoFilter-要删除的行越多，获取的速度越快

This uses an AutoFilter - the more rows to delete, the faster it gets

Rows: 1,048,575 (Deleted: 524,286), Cols: 21   (70 Mb xlsb file)

Time: 6.90 sec, 7.49 sec, 7.21 sec   (3 tests)

下面显示的测试数据

工作原理

• 它会生成一个公式为"=RIGHT(T1, 2)"的临时帮助列(第一个空列)
• 为年份保留一个过滤器，以将("<18")保留在temp列中
• 将所有可见行复制到新工作表(不包括临时列)
• 删除初始工作表
• 将新工作表重命名为初始工作表名称

• It generates a temporary helper column with formula "=RIGHT(T1, 2)" (first empty column)
• Applies a filter for the years to keep ("<18") in the temp column
• Copies all visible rows to a new sheet (not including the temp column)
• Removes the initial sheet
• Renames the new sheet to the initial sheet name

Option Explicit

Public Sub RemoveYearsAfter18()
    Dim ws As Worksheet, wsName As String, lr As Long, lc As Long
    Dim ur As Range, filterCol As Range, newWs As Worksheet

    Set ws = Sheet1     'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
    wsName = ws.Name

    lr = ws.Cells(ws.Rows.Count, "T").End(xlUp).Row         'Last Row in col T (or 635475)
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Last Col in row 1

    Set ur = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))
    Set filterCol = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) 'Exclude Headers

    OptimizeApp True
    Set newWs = ThisWorkbook.Worksheets.Add(After:=ws)  'Add new sheet
    With filterCol
        .Formula = "=RIGHT(T1, 2)"
        .Cells(1) = "FilterCol"                     'Column header
        .Value2 = .Value2                           'Convert formulas to values for filter
    End With
    filterCol.AutoFilter Field:=1, Criteria1:="<18" 'Reverse filter

    ur.Copy                                         'Copy visible data
    With newWs.Cells
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteAll                    'Paste data on new sheet
        .Cells(1).Select
    End With

    ws.Delete                                       'Delete old sheet
    newWs.Name = wsName
    OptimizeApp False
End Sub

---

Private Sub OptimizeApp(ByVal speedUp As Boolean)
    Application.Calculation = IIf(speedUp, xlCalculationManual, xlCalculationAutomatic)
    Application.ScreenUpdating = Not speedUp
    Application.DisplayAlerts = Not speedUp
    Application.EnableEvents = Not speedUp
End Sub

---

之前

---

Before

之后

这篇关于VBA脚本导致Excel在15个循环后无法响应的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！