Deleting certain rows in 95,000 row worksheet

bthurman1220

New Member
Joined
Oct 24, 2019
Messages
11
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,

Code:
'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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
30,317
Office Version
365
Platform
Windows
How about
Code:
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

New Member
Joined
Oct 24, 2019
Messages
11
How about
Code:
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.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
30,317
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback.
 

Forum statistics

Threads
1,077,991
Messages
5,337,591
Members
399,156
Latest member
RaudMees

Some videos you may like

This Week's Hot Topics

Top