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

Answer 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 ）。

这个答案提供了在涉及大量行时有条件地删除行的最有效方法。 如果可以，添加一个帮助列来计算您的条件（例如，对于要保留的行，使其返回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

Answer 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

Answer 3

这段代码处理635475在我的快速计算机上以12.48秒的速度排列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

Answer 4

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

---

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

---

之前

后

---

Answer 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行的21列数据需要11秒