Is there a better way to do this?

I have this code but it does take a little time to execute - is there a better approach to this?

Dim lRow
lRow = 3000
Do While lRow >= 2
If Cells(lRow, 9) <> "Successful" Then Rows(lRow).Delete
lRow = lRow - 1
Loop

Open in new window

gisvpnAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
Automating AutoFilter will be faster. This code might need adjusting slightly

Option Explicit

Sub deleteFilteredData()
    Dim rDelete    As Range
    Dim lCalc  As Long
    Dim sDelete As String
     
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
 On Error GoTo exit_proc
     
     'Obtain the value that you want to delete
    sDelete = "Successful"
  
     
     'Sheet with the data, change the name
    With Sheet1
        .AutoFilterMode = False
         
         'Apply the filter, this range of data starts in A1
        .Cells(1, 1).CurrentRegion.AutoFilter Field:=9, Criteria1:=sDelete
         
        With .AutoFilter.Range
            On Error Resume Next
            Set rDelete = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
            .SpecialCells(xlCellTypeVisible)
'            On Error GoTo 0
            If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
        End With
         'Remove the AutoFilter
        .AutoFilterMode = False
    End With
     
exit_proc:
        .ScreenUpdating = True
        .Calculation = lCalc
    End With
     
End Sub

Open in new window

0
Martin LissOlder than dirtCommented:
Whenever deleting rows you should do it backward

Dim lRow

For lRow = 3000 to 2 step -1
    If Cells(lRow, 9) <> "Successful" Then Rows(lRow).Delete
Next

Open in new window

0
Roy CoxGroup Finance ManagerCommented:
The OP's code already deletes backwards from 3000

Creating a range to delete will be faster

Option Explicit

Sub DeleteRows()
    Dim rRng As Range, rDelete As Range, rCl As Ranges

    Set rRng = Cells(1, 9).CurrentRegion    '///limits the number of Rows

    For Each rCl In rRng
        If rCl.Value <> "Successful" Then
            If rDelete Is Nothing Then
                Set rDelete = rCl
            Else: Set rCl = Union(rDelete, rCl)
            End If
        End If
    Next rCl
    If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End Sub

Open in new window


However, AutoFilter will be faster than a Loop.

Note the criteia in my earlier post should be <> "Successful" not ="Successful"
0
Roy CoxGroup Finance ManagerCommented:
Just spotted an typo in the code, it should be

Option Explicit

Sub DeleteRows()
    Dim rRng As Range, rDelete As Range, rCl As Ranges

    Set rRng = Cells(1, 9).CurrentRegion    '///limits the number of Rows

    For Each rCl In rRng
        If rCl.Value <> "Successful" Then
            If rDelete Is Nothing Then
                Set rDelete = rCl
            Else: Set rDelete = Union(rDelete, rCl)
            End If
        End If
    Next rCl
    If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End Sub
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Martin LissOlder than dirtCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.