Deleting certain rows in 95,000 row worksheet

[bthurman1220]

I am using the code below to search cells for certain criteria and then keeping certain
rows and deleting certain rows.

This code currently takes around 1 hour to process 95,000 records. I need help in
determining if there is a better way.

Thanks,

'Delete Level 1's and certain Level 2's
X = 2
Dim vLvlDel As Long
vLvlDel = 1
Do Until Cells(X, 1) = ""
    
    vLvl = Cells(X, 14)
    vJobCode = Cells(X, 16)
    Application.StatusBar = "Working on Row " & vLvlDel
    
    Select Case vLvl
        Case "Level 1"
            Cells(X, 1).EntireRow.Delete
        Case "Level 3"
            X = X + 1
        Case "Level 4"
            X = X + 1
        Case "Level 2"
            Select Case vJobCode
                Case "10127"
                    X = X + 1
                Case "10205"
                    X = X + 1
                Case "10206"
                    X = X + 1
                Case "11414"
                    X = X + 1
                Case "11428"
                    X = X + 1
                Case "11754"
                    X = X + 1
                Case "11769"
                    X = X + 1
            Case Else
                Cells(X, 1).EntireRow.Delete
            End Select
        
    End Select
    
    vLvlDel = vLvlDel + 1
    
Loop


MsgBox vLvlDel & " Rows Processed"

 

[Fluff]

How about

Sub bthurman()
    Dim Cl As Range, Rng As Range
    
    For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Cl.Offset(, 13).Value = "Level 1" Then
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
        ElseIf Cl.Offset(, 13).Value = "Level 2" Then
            Select Case Cl.Offset(, 15).Value
                Case "10127", "10205", "10206", "11414", "11428", "11754", "11769"
                Case Else
                    If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
            End Select
        End If
    Next Cl
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[bthurman1220]

How about

Sub bthurman()
    Dim Cl As Range, Rng As Range
    
    For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Cl.Offset(, 13).Value = "Level 1" Then
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
        ElseIf Cl.Offset(, 13).Value = "Level 2" Then
            Select Case Cl.Offset(, 15).Value
                Case "10127", "10205", "10206", "11414", "11428", "11754", "11769"
                Case Else
                    If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
            End Select
        End If
    Next Cl
    If Not Rng Is Nothing Then Rng.EntireRow.Delete


End Sub

Thanks so much Fluff - I will give this a try and let you know.

 

[bthurman1220]

Thanks so much Fluff. Your code trimmed 35 minutes off the processing time.

 

[Fluff]

You're welcome & thanks for the feedback.