Excel VBA性能 - 100万行 - 在不到1分钟的时间内删除包含值的行

Question

Excel VBA性能 - 100万行 - 在不到1分钟的时间内删除包含值的行我试图在不到一分钟的时间内找到一种方法来过滤大数据并删除工作表中的行目标：在第1列中查找包含特定文本的所有记录，然后删除整行保持所有单元格格式（颜色，字体，边框，列宽）和公式。测试数据：：。代码如何工作：首先关闭所有Excel功能如果工作簿不为空，并且要删除的文本值存在于第1列中将单元格地址添加到格式的tmp字符串中 "A11,A275,A3900,..."如果tmp变量长度接近255个字符使用删除行 .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp将tmp重置为空并继续前进到下一组行将列1的已使用范围复制到数组向后迭代数组中的每个值当找到匹配时：最后，它将所有Excel功能重新打开。主要问题是删除操作，总持续时间应低于一分钟。任何基于代码的解决方案都是可以接受的，只要它在1分钟内执行即可。这将范围缩小到极少数可接受的答案。已经提供的答案也非常简短，易于实施。一个人在大约30秒内执行操作，因此至少有一个答案提供了可接受的解决方案，其他人可能会发现它也很有用。我的主要初始功能：Sub DeleteRowsWithValuesStrings()     Const MAX_SZ As Byte = 240     Dim i As Long, j As Long, t As Double, ws As Worksheet    Dim memArr As Variant, max As Long, tmp As String     Set ws = Worksheets(1)     max = GetMaxCell(ws.UsedRange).Row     FastWB True:    t = Timer    With ws        If max > 1 Then             If IndexOfValInRowOrCol("Test String", , ws.UsedRange) > 0 Then                 memArr = .Range(.Cells(1, 1), .Cells(max, 1)).Value2                For i = max To 1 Step -1                     If memArr(i, 1) = "Test String" Then                         tmp = tmp & "A" & i & ","                         If Len(tmp) > MAX_SZ Then                            .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp                            tmp = vbNullString                        End If                     End If                 Next                 If Len(tmp) > 0 Then                     .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp                End If                 .Calculate            End If         End If     End With     FastWB False:   InputBox "Duration: ", "Duration", Timer - tEnd Sub

Answer 1

如果源数据不包含公式，或者方案允许（或希望）在条件行删除期间将公式转换为硬值，则可以实现速度的显着提高。

以上作为警告，我的解决方案使用范围对象的AdvancedFilter。它的速度大约是DeleteRowsWithValuesNewSheet（）的两倍。

Public Sub ExcelHero()
    Dim t#, crit As Range, data As Range, ws As Worksheet    Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
    FastWB True
    t = Timer        Set fc = ActiveSheet.UsedRange.Item(1)
        Set lc = GetMaxCell        Set data = ActiveSheet.Range(fc, lc)
        Set ws = Sheets.Add        With data            Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
            Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
            With fr2
                fr1.Copy                .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll                .Item(1).Select
            End With
            Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
            crit = [{"Column 1";"<>Test String"}]
            .AdvancedFilter xlFilterCopy, crit, fr2            .Worksheet.Delete        End With

    FastWB False
    r = ws.UsedRange.Rows.Count
    Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"End Sub

Answer 2

在我的老人戴尔Inspiron 1564（Win 7 Office 2007）上：

Sub QuickAndEasy()
    Dim rng As Range    Set rng = Range("AA2:AA1000001")
    Range("AB1") = Now
    Application.ScreenUpdating = False
        With rng            .Formula = "=If(A2=""Test String"",0/0,A2)"
            .Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete            .Clear        End With
    Application.ScreenUpdating = True
    Range("AC1") = NowEnd Sub

跑了大概10秒钟。我假设AA列可用。

编辑＃1：

请注意，此代码未将“ 计算 ” 设置为“手动”。如果在允许“帮助”列计算后将计算模式设置为手动，则性能将得到改善。