Question

下面的代码工作得很好，因为预期唯一的缺点是它很慢，因为我使用它来搜索子字符串的所有实例，如果在整个工作簿的任何单元格中找到，则删除整行。

如果在任何单元格字符串中找到输入的字符串

，目标很简单，只需删除整个行

Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range

Option Compare Text
Option Explicit

Sub SearchDelete()

toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0

If toFind = "" Then
    MsgBox "Empty String Entered.Exiting Sub Now."
    Exit Sub
Else
        WS_Count = ActiveWorkbook.Worksheets.Count

        'Begin the loop.
        For I = 1 To WS_Count

Label1:
                For Each Cell In Worksheets(I).UsedRange.Cells

                    If Trim(Cell.Text) <> "" Then
                        pos = 0
                        pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)

                        If pos > 0 Then     'match Found'

                            cutRow = Cell.Row
                            Worksheets(I).Rows(cutRow).EntireRow.Delete
                            j = j + 1
                           GoTo Label1
                        Else: End If

                    Else: End If

                Next Cell
         Next I
End If

MsgBox "Total " & j & " Rows were deleted!"

End Sub

Answer 1

单个操作几乎总是比批量操作慢，Range.Delete method也不例外。使用Union method收集匹配的行，然后执行删除 en masse 将大大加快操作速度。

暂时挂起某些应用程序环境处理程序也会有所帮助。在删除行时，您不需要Application.ScreenUpdating处于活动状态;只有在你完成手术后才能使用。

Option Explicit
Option Compare Text

Sub searchDelete()
    Dim n As Long, w As Long
    Dim toFind As String, addr As String
    Dim fnd As Range, rng As Range

    toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
    toFind = Trim(toFind)

    If Not CBool(Len(toFind)) Then
        MsgBox "Empty String Entered.Exiting Sub Now."
        GoTo bm_Safe_Exit
    End If

    'appTGGL bTGGL:=False   'uncomment this line when you have finsihed debugging

    With ActiveWorkbook
        For w = 1 To .Worksheets.Count
            With .Worksheets(w)
                Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
                            after:=.Cells.SpecialCells(xlCellTypeLastCell))
                If Not fnd Is Nothing Then
                    Set rng = .Rows(fnd.Row)
                    n = n + 1
                    addr = fnd.Address
                    Do
                        If Intersect(fnd, rng) Is Nothing Then
                            n = n + 1
                            Set rng = Union(rng, .Rows(fnd.Row))
                        End If
                        Set fnd = .Cells.FindNext(after:=fnd)
                    Loop Until addr = fnd.Address
                    Debug.Print rng.Address(0, 0)
                    rng.Rows.EntireRow.Delete
                End If
            End With
        Next w
    End With

    Debug.Print "Total " & n & " rows were deleted!"

bm_Safe_Exit:
    appTGGL

End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    Debug.Print Timer
End Sub

Answer 2

您的问题的答案："How to speed up this code to find and delete rows if a substring is found"是 - 请勿在您找到并删除该行后从表格顶部重复搜索！

如果找到子字符串，如何加快此代码以查找和删除行

2 个答案: