Excel VBA 性能 - 100 万行 - 删除包含值的行，不到 1 分钟

Excel VBA Performance - 1 million rows - Delete rows containing a value, in less than 1 min

提问by paul bica

I am trying to find a way to filter large data and remove rows in a worksheet, in less than one minute

我正在尝试找到一种方法来过滤大数据并在不到一分钟的时间内删除工作表中的行

The goal:

目标：

• Find all records containing specific text in column 1, and delete the entire row
• Keep all cell formatting (colors, font, borders, column widths) and formulas as they are

• 查找第 1 列中包含特定文本的所有记录，并删除整行
• 保持所有单元格格式（颜色、字体、边框、列宽）和公式不变

.

.

Test Data:

测试数据：

:

：

.

.

How the code works:

代码如何工作：

1. It starts by turning all Excel features Off

2. If the workbook is not empty and the text value to be removed exists in column 1

   • Copies the used range of column 1 to an array
   • Iterates over every value in array backwards

   • When it finds a match:

     • Appends the cell address to a tmp string in the format "A11,A275,A3900,..."
     • If the tmp variable length is close to 255 characters
     • Deletes rows using .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
     • Resets tmp to empty and moves on to the next set of rows
3. At the end, it turns all Excel features back On

1. 首先关闭所有 Excel 功能

2. 如果工作簿不为空并且要删除的文本值存在于第 1 列中

   • 将第 1 列的使用范围复制到数组
   • 向后迭代数组中的每个值

   • 当它找到匹配项时：

     • 将单元格地址附加到格式中的 tmp 字符串 "A11,A275,A3900,..."
     • 如果 tmp 变量长度接近 255 个字符
     • 删除行使用 .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
     • 将 tmp 重置为空并移至下一组行
3. 最后，它会重新打开所有 Excel 功能

.

.

The main issue is the Delete operation, and total duration time should be under one minute. Any code-based solution is acceptable as long as it performs under 1 minute.

主要问题是删除操作，总持续时间应小于一分钟。任何基于代码的解决方案都可以接受，只要它的执行时间低于 1 分钟。

This narrows the scope to very few acceptable answers. The answers already provided are also very short and easy to implement. Oneperforms the operation in about 30 seconds, so there is at least one answer that provides an acceptable solution, and other may find it useful as well

这将范围缩小到极少数可接受的答案。已经提供的答案也非常简短且易于实施。一个人在大约 30 秒内执行该操作，因此至少有一个答案提供了可接受的解决方案，而其他人可能会发现它也很有用

.

.

My main initial function:

我的主要初始功能：

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 - t
End Sub

---

---

Helper functions (turn Excel features off and on):

辅助函数（关闭和打开 Excel 功能）：

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
    FastWS , opt
End Sub

Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
                  Optional ByVal opt As Boolean = True)
    If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
    Else
        EnableWS ws, opt
    End If
End Sub

Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
    With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
    End With
End Sub

---

---

Finds last cell with data (thanks @ZygD - now I tested it in several scenarios):

查找带有数据的最后一个单元格（感谢@ZygD - 现在我在几种情况下对其进行了测试）：

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

---

---

Returns the index of a match in the array, or 0 if a match is not found:

返回数组中匹配项的索引，如果未找到匹配项，则返回 0：

Public Function IndexOfValInRowOrCol( _
                                    ByVal searchVal As String, _
                                    Optional ByRef ws As Worksheet = Nothing, _
                                    Optional ByRef rng As Range = Nothing, _
                                    Optional ByRef vertical As Boolean = True, _
                                    Optional ByRef rowOrColNum As Long = 1 _
                                    ) As Long

    'Returns position in Row or Column, or 0 if no matches found

    Dim usedRng As Range, result As Variant, searchRow As Long, searchCol As Long

    result = CVErr(9999) '- generate custom error

    Set usedRng = GetUsedRng(ws, rng)
    If Not usedRng Is Nothing Then
        If rowOrColNum < 1 Then rowOrColNum = 1
        With Application
            If vertical Then
                result = .Match(searchVal, rng.Columns(rowOrColNum), 0)
            Else
                result = .Match(searchVal, rng.Rows(rowOrColNum), 0)
            End If
        End With
    End If
    If IsError(result) Then IndexOfValInRowOrCol = 0 Else IndexOfValInRowOrCol = result
End Function

.

.

Update:

更新：

Tested 6 solutions (3 tests each): Excel Hero's solution is the fastestso far (removes formulas)

测试了 6 个解决方案（每个解决方案 3 个测试）：Excel Hero 的解决方案是迄今为止最快的（删除了公式）

.

.

Here are the results, fastest to the slowest:

以下是结果，从最快到最慢：

.

.

Test 1. Total of 100,000 records, 10,000 to be deleted:

测试一、共10万条记录，删除1万条：

1. ExcelHero()                    - 1.5 seconds

2. DeleteRowsWithValuesNewSheet() - 2.4 seconds

3. DeleteRowsWithValuesStrings()  - 2.45 minutes
4. DeleteRowsWithValuesArray()    - 2.45 minutes
5. QuickAndEasy()                 - 3.25 minutes
6. DeleteRowsWithValuesUnion()    - Stopped after 5 minutes

.

.

Test 2. Total of 1 million records, 100,000 to be deleted:

测试2.总共100万条记录，10万条被删除：

1. ExcelHero()                    - 16 seconds (average)

2. DeleteRowsWithValuesNewSheet() - 33 seconds (average)

3. DeleteRowsWithValuesStrings()  - 4 hrs 38 min (16701.375 sec)
4. DeleteRowsWithValuesArray()    - 4 hrs 37 min (16626.3051757813 sec)
5. QuickAndEasy()                 - 5 hrs 40 min (20434.2104492188 sec)
6. DeleteRowsWithValuesUnion()    - N/A

.

.

Notes:

笔记：

1. ExcelHero method: easy to implement, reliable, extremely fast, but removes formulas
2. NewSheet method: easy to implement, reliable, and meets the target
3. Strings method: more effort to implement, reliable, but doesn't meet requirement
4. Array method: similar to Strings, but ReDims an array (faster version of Union)
5. QuickAndEasy: easy to implement (short, reliable and elegant), but doesn't meet requirement
6. Range Union: implementation complexity similar to 2 and 3, but too slow

1. ExcelHero 方法：易于实现、可靠、极快，但删除公式
2. NewSheet 方法：易于实现、可靠且符合目标
3. Strings 方法：更努力实现，可靠，但不符合要求
4. Array 方法：类似于 Strings，但 ReDims 一个数组（Union 的更快版本）
5. QuickAndEasy：易于实现（简短、可靠且优雅），但不符合要求
6. Range Union：实现复杂度类似于2和3，但太慢

I also made the test data more realistic by introducing unusual values:

我还通过引入异常值使测试数据更加真实：

• empty cells, ranges, rows, and columns
• special characters, like =[`~!@#$%^&*()_-+{}[]\|;:'",.<>/?, separate and multiple combinations
• blank spaces, tabs, empty formulas, border, font, and other cell formatting
• large and small numbers with decimals (=12.9999999999999 + 0.00000000000000001)
• hyperlinks, conditional formatting rules
• empty formatting inside and outside data ranges
• anything else that might cause data issues

• 空单元格、范围、行和列
• 特殊字符，如 =[`~!@#$%^&*()_-+{}[]\|;:'",.<>/?, 单独和多个组合
• 空格、制表符、空公式、边框、字体和其他单元格格式
• 带小数的大数和小数 (=12.9999999999999 + 0.00000000000000001)
• 超链接、条件格式规则
• 数据范围内外的空格式
• 任何其他可能导致数据问题的东西

采纳答案by paul bica

I'm providing the first answer as a reference

我提供第一个答案作为参考

Others may find it useful, if there are no other options available

如果没有其他选项可用，其他人可能会发现它很有用

• Fastest way to achieve the result is not to use the Delete operation
• Out of 1 million records it removes 100,000 rows in an average of 33 seconds

• 达到结果的最快方法是不使用删除操作
• 在 100 万条记录中，它平均在33 秒内删除了 100,000 行

.

.

Sub DeleteRowsWithValuesNewSheet()  '100K records   10K to delete
                                    'Test 1:        2.40234375 sec
                                    'Test 2:        2.41796875 sec
                                    'Test 3:        2.40234375 sec
                                    '1M records     100K to delete
                                    'Test 1:        32.9140625 sec
                                    'Test 2:        33.1484375 sec
                                    'Test 3:        32.90625   sec
    Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
    Dim wsName As String, t As Double, oldUsedRng As Range

    FastWB True:    t = Timer

    Set oldWs = Worksheets(1)
    wsName = oldWs.Name

    Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))

    If oldUsedRng.Rows.Count > 1 Then                           'If sheet is not empty
        Set newWs = Sheets.Add(After:=oldWs)                    'Add new sheet
        With oldUsedRng
            .AutoFilter Field:=1, Criteria1:="<>Test String"
            .Copy                                               'Copy visible data
        End With
        With newWs.Cells
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll                            'Paste data on new sheet
            .Cells(1, 1).Select                                 'Deselect paste area
            .Cells(1, 1).Copy                                   'Clear Clipboard
        End With
        oldWs.Delete                                            'Delete old sheet
        newWs.Name = wsName
    End If
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub

.

.

At high level:

在高级别：

• It creates a new worksheet, and keeps a reference to the initial sheet
• AutoFilters column 1 on the searched text: .AutoFilter Field:=1, Criteria1:="<>Test String"
• Copies all (visible) data from initial sheet
• Pastes column widths, formats, and data to the new sheet
• Deletes initial sheet
• Renames the new sheet to the old sheet name

• 它创建一个新工作表，并保留对初始工作表的引用
• 自动筛选搜索文本的第 1 列： .AutoFilter Field:=1, Criteria1:="<>Test String"
• 从初始工作表复制所有（可见）数据
• 将列宽、格式和数据粘贴到新工作表
• 删除初始工作表
• 将新工作表重命名为旧工作表名称

It uses the same helper functions posted in the question

它使用问题中发布的相同帮助函数

The 99% of the duration is used by the AutoFilter

99% 的持续时间由 AutoFilter 使用

.

.

There are a couple limitations I found so far, the first can be addressed:

到目前为止，我发现了一些限制，第一个可以解决：

1. If there are any hidden rows on the initial sheet, it unhides them

   • A separate function is needed to hide them back
   • Depending on implementation, it might significantly increase duration

2. VBA related:

   • It changes the Code Name of the sheet; other VBA referring to Sheet1 will be broken (if any)
   • It deletes all VBA code associated with the initial sheet (if any)

1. 如果初始工作表上有任何隐藏的行，它会取消隐藏它们

   • 需要一个单独的函数来隐藏它们
   • 根据实施情况，它可能会显着增加持续时间

2. VBA相关：

   • 它改变了工作表的代码名称；其他引用 Sheet1 的 VBA 将被破坏（如果有）
   • 它删除与初始工作表关联的所有 VBA 代码（如果有）

.

.

A few notes about using large files like this:

关于使用像这样的大文件的一些注意事项：

• The binary format (.xlsb) reduce file size dramatically (from 137 Mb to 43 Mb)

• Unmanaged Conditional Formatting rules can cause exponential performance issues

  • The same for Comments, and Data validation

• Reading file or data from network is much slower than working with a locall file

• 二进制格式 (.xlsb) 显着减小了文件大小（从 137 Mb 到 43 Mb）

• 非托管条件格式规则可能会导致指数性能问题

  • 评论和数据验证相同

• 从网络读取文件或数据比使用本地文件慢得多

回答by Excel Hero

A significant gain in speed can be achieved if the source data do not contain formulas, or if the scenario would allow (or want) the formulas to be converted into hard values during the conditional row deletions.

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

With the above as a caveat, my solution uses the AdvancedFilter of the range object. It's about twice as fast as DeleteRowsWithValuesNewSheet().

以上作为警告，我的解决方案使用范围对象的 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

回答by Gary's Student

On my elderly Dell Inspiron 1564 (Win 7 Office 2007) this:

在我年长的 Dell 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") = Now
End Sub

took about 10 seconds to run. I am assuming that column AAis available.

大约需要 10 秒才能运行。我假设列AA可用。

EDIT#1:

编辑#1：

Please note that this code does notset Calculationto Manual. Performance will improve if the Calculation mode is set to Manual afterthe "helper" column is allowed to calculate.

请注意，此代码未将计算设置为手动。如果在允许“helper”列计算后将计算模式设置为手动，则性能将提高。

回答by Gary's Student

I know I'm incredibly late with my answer here however future visitors may find it very useful.

我知道我在这里回答得太晚了，但是未来的访问者可能会发现它非常有用。

Please Note:My approach requires an index column for the rows to end up in the original order, however if you do not mind the rows being in a different order then an index column isn't needed and the additional line of code can be removed.

请注意：我的方法要求行的索引列以原始顺序结束，但是如果您不介意行的顺序不同，则不需要索引列并且可以删除额外的代码行.

My approach:My approach was to simply select all the rows in the selected range (column), sort them in ascending order using Range.Sortand then collecting the first and last index of "Test String"within the selected range (column). I then create a range from the first and last indices and use Range.EntrieRow.Deleteto remove all the rows which contain "Test String".

我的方法：我的方法是简单地选择所选范围（列）中的所有行，使用升序对它们进行排序Range.Sort，然后收集"Test String"所选范围（列）内的第一个和最后一个索引。然后我从第一个和最后一个索引创建一个范围，并用于Range.EntrieRow.Delete删除所有包含"Test String".

Pros:
- It is blazing fast.
- It doesn't remove formatting, formulas, charts, pictures or anything like the method which copies to a new sheet.

优点：
- 它非常快。
- 它不会删除格式、公式、图表、图片或任何类似复制到新工作表的方法。

Cons:
- A decent size of code to implement however it is all straight-forward.

缺点：
- 要实现的代码量很大，但它很简单。

Test Range Generation Sub:

测试范围生成子：

Sub DevelopTest()
    Dim index As Long
    FastWB True
    ActiveSheet.UsedRange.Clear
    For index = 1 To 1000000 '1 million test
        ActiveSheet.Cells(index, 1).Value = index
        If (index Mod 10) = 0 Then
            ActiveSheet.Cells(index, 2).Value = "Test String"
        Else
            ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
        End If
    Next index
    Application.StatusBar = ""
    FastWB False
End Sub

Filter And Delete Rows Sub:

过滤和删除行子：

Sub DeleteRowFast()
    Dim curWorksheet As Worksheet 'Current worksheet vairable

    Dim rangeSelection As Range   'Selected range
    Dim startBadVals As Long      'Start of the unwanted values
    Dim endBadVals As Long        'End of the unwanted values
    Dim strtTime As Double        'Timer variable
    Dim lastRow As Long           'Last Row variable
    Dim lastColumn As Long        'Last column variable
    Dim indexCell As Range        'Index range start
    Dim sortRange As Range        'The range which the sort is applied to
    Dim currRow As Range          'Current Row index for the for loop
    Dim cell As Range             'Current cell for use in the for loop

    On Error GoTo Err
        Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8)    'Get the desired range from the user
        Err.Clear

    M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
    Select Case M1
        Case vbYes
            FastWB True  'Enable fast workbook
        Case vbNo
            FastWB False 'Disable fast workbook
    End Select

    strtTime = Timer     'Begin the timer

    Set curWorksheet = ActiveSheet
    lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
    lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column

    Set indexCell = curWorksheet.Cells(1, 1)

    On Error Resume Next

    If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do

        lastVisRow = rangeSelection.Rows.Count

        Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range

        sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest

        startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
        endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

        curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.

        sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
    End If

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

THIS CODE USES FastWB, FastWSAND EnableWSBY Paul Bica!

此代码使用FastWB，FastWS和EnableWS保罗BICA！

Times at 100K entries (10k to be removed, FastWB True):
1. 0.2 seconds.
2. 0.2 seconds.
3. 0.21 seconds.
Avg. 0.2 seconds.

100K 条目的时间（10k 被删除，FastWB True）：
1. 0.2 秒。
2. 0.2 秒。
3. 0.21 秒。
平均 0.2 秒。

Times at 1 million entries (100k to be removed, FastWB True):
1. 2.3 seconds.
2. 2.32 seconds.
3. 2.3 seconds.
Avg. 2.31 seconds.

100 万个条目的时间（100k 被删除，FastWB True）：
1. 2.3 秒。
2. 2.32 秒。
3. 2.3 秒。
平均 2.31 秒。

Running on: Windows 10, iMac i3 11,2 (From 2010)

运行于：Windows 10、iMac i3 11,2（2010 年起）

EDIT
This code was originally designed with the purpose of filtering out numeric values outside of a numeric range and has been adapted to filter out "Test String"so some of the code may be redundant.

编辑
此代码最初设计的目的是过滤掉数字范围之外的数值，并且已被调整以过滤掉，"Test String"因此某些代码可能是多余的。

回答by Andrew Toomey

Your use of arrays in calculating the used range and row count may effect the performance. Here's another approach which in testing proves efficient across 1m+ rows of data - between 25-30 seconds. It doesn't use filters so will delete rows even if hidden. Deleting a whole row won't effect formatting or column widths of the other remaining rows.

您在计算使用范围和行数时使用数组可能会影响性能。这是另一种方法，在测试中证明在 100 多行数据中有效 - 25-30 秒之间。它不使用过滤器，因此即使隐藏也会删除行。删除整行不会影响其他剩余行的格式或列宽。

1. First, check if the ActiveSheet has "Test String". Since you're only interested in Column 1 I used this:

   TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
   If TCount > 0 Then
   

2. Instead of using your GetMaxCell() function I simply used Cells.SpecialCells(xlCellTypeLastCell).Rowto get the last row:

   EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
   

3. Then loop through the rows of data:

   While r <= EndRow
   

4. To test if the cell in Column 1 is equal to "Test String":

   If sht.Cells(r, 1).Text) = "Test String" Then
   

5. To delete the row:

   Rows(r).Delete Shift:=xlUp
   

1. 首先，检查 ActiveSheet 是否有“测试字符串”。由于您只对第 1 列感兴趣，因此我使用了这个：

   TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
   If TCount > 0 Then
   

2. 而不是使用您的 GetMaxCell() 函数，我只是用来Cells.SpecialCells(xlCellTypeLastCell).Row获取最后一行：

   EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
   

3. 然后循环遍历数据行：

   While r <= EndRow
   

4. 要测试第 1 列中的单元格是否等于“测试字符串”：

   If sht.Cells(r, 1).Text) = "Test String" Then
   

5. 要删除行：

   Rows(r).Delete Shift:=xlUp
   

Putting it all together full code below. I've set ActiveSheet to a variable Sht and added turned of ScreenUpdating to improve efficiency. Since it's a lot of data I make sure to clear variables at the end.

将它们放在一起完整的代码如下。我已将 ActiveSheet 设置为变量 Sht 并添加了 ScreenUpdating 以提高效率。由于它有很多数据，我确保最后清除变量。

Sub RowDeleter()
    Dim sht As Worksheet
    Dim r As Long
    Dim EndRow As Long
    Dim TCount As Long
    Dim s As Date
    Dim e As Date

    Application.ScreenUpdating = True
    r = 2       'Initialise row number
    s = Now     'Start Time
    Set sht = ActiveSheet
    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Check if "Test String" is found in Column 1
    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
    If TCount > 0 Then

        'loop through to the End row
        While r <= EndRow
            If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
                sht.Rows(r).Delete Shift:=xlUp
                r = r - 1
            End If
            r = r + 1
        Wend
    End If
    e = Now  'End Time
    D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
    Application.ScreenUpdating = True
    DurationTime = TimeSerial(0, 0, D)
    MsgBox Format(DurationTime, "hh:mm:ss")
End Sub