vba - VBA 脚本导致 Excel 在 15 次循环后没有响应

Question

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

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

score 5 · Accepted Answer

每次我在 5 秒后运行脚本时，我的光标都会变成旋转的圆圈，并且 excel 程序变得无响应。

这很正常。VBA 在单个可用的 UI 线程上运行，与 Excel 运行在同一个线程上。当它忙于运行你的循环时，它无法响应其他刺激，并通过在标题栏中输入“（不响应）”来告诉你，直到它完成工作并能够继续做它需要做的所有其他事情（即监听鼠标和键盘消息等）。

您可以在该循环的主体中添加一点DoEvents，以允许 Excel 在迭代之间呼吸并处理待处理的消息，但是有一个问题：首先，您的代码将需要更长的时间才能完成，其次，如果用户能够选择/activate 在该循环中间的另一张表，然后是这个不合格的Range调用：

vData = Range(.Cells(1, 20), .Cells(635475, 20))

...将是运行时错误 1004 的来源，因为您无法执行Sheet1.Range(Sheet2.Cells(1,20), Sheet2.Cells(635475,20))并期望 Excel 知道如何处理该错误（假设Sheet2循环开始时处于活动状态，并且用户在其中激活Sheet1） .

这个答案提供了在涉及大量行时有条件地删除行的最有效方法。如果可以，添加一个帮助列来计算您的条件（例如，使其返回TRUE以保留FALSE行和删除行），然后使用Worksheet.ReplaceandWorksheet.SpecialCells执行过滤和删除：

.Columns("Z:Z").Replace What:=False, _
                        Replacement:="", _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        MatchCase:=False, _
                        SearchFormat:=False, _
                        ReplaceFormat:=False
.Columns("Z:Z").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

然后你就不需要循环了，它实际上可能在你数到 5 秒之前就完成了。

除此之外，长时间运行的操作就是：长时间运行的操作。拥有它：

Application.StatusBar = "Please wait..."
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'..code..

Application.Cursor = xlDefault
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False

score 4 · Accepted Answer

这似乎很快。它把结果放在 U1 和下面，所以你可能想要修改它。这会将您想要的值提取到第二个数组中。

Sub removeWrongYear()

Dim i As Long, vData As Variant, v2(), j As Long

vData = Range(Cells(1, 20), Cells(635475, 20))
ReDim v2(1 To UBound(vData, 1), 1 To 1)

For i = UBound(vData) To 2 Step -1
    If Val(Right(vData(i, 1), 2)) <= 17 Then
        j = j + 1
        v2(j, 1) = vData(i, 1)
    End If
Next i

Range("U1").Resize(j, 1) = v2

End Sub

score 2 · Accepted Answer

此代码在我的快速计算机上在 12.48 秒内处理 635475 行 x 20 列，在我的旧计算机上处理 33.32 秒（38k x 20 为 0.84 和 2.06 秒）。

Option Explicit

Sub removeWrongYear2()
    Const DATE_COLUMN = 20
    Dim StartTime As Double: StartTime = Timer

    Dim data() As Variant, results() As Variant
    Dim c As Long, r As Long, r2 As Long
    With ActiveSheet
        data = .UsedRange.Value
        ReDim results(1 To UBound(data), 1 To UBound(data, 2))

        For r = 2 To UBound(data)
            If Val(Right(data(r, DATE_COLUMN), 2)) <= 17 Then
                r2 = r2 + 1
                For c = 1 To UBound(data, 2)
                    results(r2, c) = data(r, c)
                Next
            End If
        Next
        If r2 > 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .UsedRange.Offset(1).Value = results
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True
        End If
    End With
    Debug.Print Round(Timer - StartTime, 2)
End Sub

Sub Setup()
    Dim data, r, c As Long
    Const LASTROW = 635475
    Cells.Clear
    data = Range(Cells(1, 1), Cells(LASTROW, 20)).Value

    For r = 1 To UBound(data)
        For c = 1 To 19
            data(r, c) = Int((LASTROW * Rnd) + 100)
        Next
        data(r, 20) = Int((10 * Rnd) + 10)
    Next
    Application.ScreenUpdating = False
    Range(Cells(1, 1), Cells(LASTROW, 20)).Value = data
    Application.ScreenUpdating = True
End Sub

score 2 · Accepted Answer

这使用AutoFilter- 要删除的行越多，它变得越快

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 列中
将所有可见行复制到新工作表（不包括临时列）
删除初始工作表
将新工作表重命名为初始工作表名称

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

前

后

score 1 · Accepted Answer

Sort()&AutoFilter()永远是一对好搭档：

Sub nn()
    Dim sortRng As Range

    With ActiveSheet.UsedRange ' reference all data in active sheet
        With .Offset(, .Columns.Count).Resize(, 1) ' get a helper column right outside data
            .Formula = "=ROW()" ' fill it with sequential numbers from top to down
            .Value = .Value ' get rid of formulas
            Set sortRng = .Cells ' store the helper range
        End With

        With .Resize(, .Columns.Count + 1) ' consider data and the helper range
            .Sort key1:=.Cells(1, 20), order1:=xlAscending, Header:=xlNo ' sort it by data in column 20 
            .AutoFilter Field:=20, Criteria1:=">=01/01/2018" ' filter it for data greater than 2017
            .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete filtered data
            .Parent.AutoFilterMode = False ' remove filter
            .Sort key1:=sortRng(1, 1), order1:=xlAscending, Header:=xlNo ' sort things back by means of helper column
            .Columns(.Columns.Count).ClearContents ' clear helper column
        End With
    End With
End Sub

在我的测试中，768k 行乘 21 列数据耗时 11 秒

vba - VBA 脚本导致 Excel 在 15 次循环后没有响应

5 回答 5

Related

Reference