Deleting unrequired rows from worksheet

[Godders199]

Hello, I have the following code which currently works perfectly and in a timely manner, I have had to add a filter in to ensure that any row that contains the word "testing" is not removed even if the adviser is on the list of not needing a check. this appears to have slowed down the functionality of this VBA, i am wondering if there is a more efficient way to code this into the VBA.

Additional code is in bold below in part two .

First part of the code creates the list i need of advisers not needing any checks., second part removes those advisers from the list.
Sub checkscompleted()
'create list of advisers not needing a check'
Sheets("checks").Select
Dim sh4 As Worksheet
Set sh4 = Worksheets("checks")
With sh4.Range("a1").CurrentRegion
Rows("2:2").Select
.AutoFilter Field:=21, Criteria1:="<=0", _
Operator:=xlAnd
End With
Columns("a:a").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("checks completed").Select
Range("a1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("checks").ShowAllData



'remove deselected advisers from allocation'
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
Dim varList As Variant
Dim lngCounter As Long
Dim UsdRws As Long
UsdRws = Sheets("checks completed").Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Sheets("submissions").Select
Cells.Select
ActiveSheet.Range("A:AJ").AutoFilter Field:=25, Criteria1:= _
"<>*testing*", Operator:=xlAnd
varList = Sheets("checks completed").Range("A1:A" & UsdRws).Value



For lngCounter = LBound(varList) To UBound(varList)

With ActiveSheet.Range("d:d")
Set rngFound = .Find( _
What:=varList(lngCounter, 1), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True _
)

If Not rngFound Is Nothing Then
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If

strFirstAddress = rngFound.Address
Set rngFound = .FindNext(After:=rngFound)

Do Until rngFound.Address = strFirstAddress
Set rngToDelete = Application.Union(rngToDelete, rngFound)
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngCounter

If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Range("a1").Select
Sheets("instructions").Select


End Sub

thanks for any help.

 

[Mister H]

Hi:

Have you tried this code with ScreenUpdating being turned off as well you can try Disabling Events? It generally speeds thing up. Turn it off at the beginning and turn it back on at the end.

Sub checkscompleted()

    Application.ScreenUpdating = False
    Application.EnableEvents = False

 'create list of advisers not needing a check'
 Sheets("checks").Select
  Dim sh4 As Worksheet
        Set sh4 = Worksheets("checks")
        With sh4.Range("a1").CurrentRegion
 Rows("2:2").Select
        .AutoFilter Field:=21, Criteria1:="<=0", _
        Operator:=xlAnd
        End With
     Columns("a:a").Select
    Application.CutCopyMode = False
    Selection.Copy
 Sheets("checks completed").Select
 Range("a1").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 Sheets("checks").ShowAllData



 'remove deselected advisers from allocation'
  Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String
    Dim varList As Variant
    Dim lngCounter As Long
 Dim UsdRws As Long
 UsdRws = Sheets("checks completed").Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    Sheets("submissions").Select
    Cells.Select
[I][B]ActiveSheet.Range("A:AJ").AutoFilter Field:=25, Criteria1:= _
        "<>*testing*", Operator:=xlAnd[/B][/I]
  varList = Sheets("checks completed").Range("A1:A" & UsdRws).Value



    For lngCounter = LBound(varList) To UBound(varList)

        With ActiveSheet.Range("d:d")
         Set rngFound = .Find( _
                                What:=varList(lngCounter, 1), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True _
                                    )

            If Not rngFound Is Nothing Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    Set rngToDelete = Application.Union(rngToDelete, rngFound)
                End If

                strFirstAddress = rngFound.Address
                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngCounter

    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
 Range("a1").Select
 Sheets("instructions").Select


    Application.ScreenUpdating = True
    Application.EnableEvents = True


 End Sub

 

[Fluff]

As an alternative
Only partially tested, so make sure you test this on a copy of your data.

Sub checkscompleted()
'create list of advisers not needing a check'
    
    Dim rngToDelete As Range
    Dim UsdRws As Long
    Dim Cl As Range

    Application.ScreenUpdating = False
    
    Sheets("checks").Select
    With CreateObject("scripting.dictionary")
        For Each Cl In Range("U2", Range("U" & Rows.Count).End(xlUp))
            If Cl.Value <= 0 Then .Item(.Count) = Cl.Offset(, -20).Value
        Next Cl
    
    'remove deselected advisers from allocation'
        Sheets("submissions").Select
        UsdRws = Range("D" & Rows.Count).End(xlUp).Row
        For Each Cl In Range("D2:D" & UsdRws)
            If UBound(Filter(.items, Cl.Value, True, vbTextCompare)) >= 0 _
                And Not Cl.Offset(, 21).Value Like "*testing*" Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = Cl
                Else
                    Set rngToDelete = Union(rngToDelete, Cl)
                End If
            End If
        Next Cl
    End With
    
    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
    Sheets("instructions").Select


End Sub