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

【问题标题】：VBA script causes Excel to not respond after 15 loopsVBA 脚本导致 Excel 在 15 次循环后没有响应
【发布时间】：2018-10-28 03:21:56
【问题描述】：

我正在运行一个脚本来查找和删除包含 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

【问题讨论】：

我认为无论你做什么都会很慢，除非你在数组中做所有事情。自动过滤器会比我认为的这种方法更快。
你也可以调用 application.screenupdating = false 在已经完成循环之后。最好先调用它。
如果您不必担心用户对 Excel 工作表的更改，您可以在 Next i 行之前添加 DoEvents。它会阻止 Excel 不响应；但是，它也会允许与您的工作簿/工作表进行一些（可能非常）延迟的交互。
@Mistella 除了你这样做，因为 Range 分配中的 Range 调用不合格。
@MathieuGuindon 我明白了。此外，With ActiveSheet 在这种情况下也可能存在很大问题。

标签： vba excel

【解决方案1】：

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

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

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

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

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

This answer 提供了在涉及很多行时有条件地删除行的最有效方法。如果可以，添加一个辅助列来计算您的条件（例如，使其返回 TRUE 保留行，返回 FALSE 删除行），然后使用 Worksheet.Replace 和 Worksheet.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

【讨论】：

两个数组不是更快吗？
@SJR 取决于涉及的行数。在那个规模上，即使是阵列也不会削减它。 Dave 的 SpecialCells 方法在 3 秒内运行了相同的 38K 行，而我的基于数组的方法在 10 倍内完成了 - 再说一次，这可能只是我做了一些愚蠢的事情......我在某处有一个比较各种方法的帖子，不确定它是否是关于删除行，但我找不到它。
我犹豫不决，但我只是尝试了 600k 行和 3 列的范围，根据检查一列转移到第二个数组，花了 3-4 秒。
@SJR 发布答案！自从戴夫的回答让我感到羞耻之后，我一直犹豫是否建议阵列解决方案 =)
我只是发布了一个两个数组的方法，它应该优于 Dave 的 SpecialCells 方法。需要注意的是，删除的行越多，数组执行的速度越快，SpecialCells 技术的速度就越慢，

【解决方案2】：

这似乎很快。它把结果放在 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

【讨论】：

【解决方案3】：

这使用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

之前

之后

【讨论】：

【解决方案4】：

此代码在我的快速计算机上在 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

【讨论】：

【解决方案5】：

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 行 x 21 列的数据耗时 11 秒

【讨论】：