Macro to Delete Data in Col G on sheet Run number

[howard]

I have data on sheet "run Number"


I have tried to write code to delete rows containing 995915 and 995925 in Col G , but code takes a long time to run

There is +- 25000 rows of data

It would be appreciated if someone could amend my code so that it runs faster
Sub Delete_995915_995925_Run_number()
Dim ws As Worksheet
Dim lastRow As Long
Dim deleteRows() As Long
Dim deleteCount As Long
Dim i As Long

' Set the worksheet object
Set ws = ThisWorkbook.Sheets("Run Number")

' Find the last row with data in column G
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row

' Loop through the rows from row 2 onwards
For i = 2 To lastRow
' Check if the value in column G matches 995915 or 995925
If ws.Cells(i, "G").Value = 995915 Or ws.Cells(i, "G").Value = 995925 Then
' Store the row number in the deleteRows array
deleteCount = deleteCount + 1
ReDim Preserve deleteRows(1 To deleteCount)
deleteRows(deleteCount) = i
End If
Next i

' Delete the rows in one go
If deleteCount > 0 Then
For i = deleteCount To 1 Step -1
ws.Rows(deleteRows(i)).Delete
Next i
End If
End Sub [

 

[kevin9999]

Hi Howard, please try this on a copy of your workbook.

Option Explicit
Sub Howard()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ *** Change to actual sheet name ***
    Dim LRow As Long, LCol As Long, i As Long
    Dim a, b
    
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    a = Range(ws.Cells(2, 7), ws.Cells(LRow, 7))
    ReDim b(1 To UBound(a), 1 To 1)
    
    For i = 1 To UBound(a)
        If a(i, 1) = "995915" Or a(i, 1) = "995925" Then b(i, 1) = 1
    Next i
    ws.Cells(2, LCol).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(ws.Columns(LCol))
    
    If i > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub

 

[howard]

Thanks Kevin. Code runs extrememely fast

 

[kevin9999]

Happy to help Howard, and thanks for the feedback

 

[Joe4]

Here is another way that uses NO loops (it uses filters), so should be pretty fast:

Sub Delete_995915_995925_Run_number()

Dim ws As Worksheet
Dim lastRow As Long
Dim lr As Long

Application.ScreenUpdating = False

' Set the worksheet object
Set ws = ThisWorkbook.Sheets("Run Number")

' Find the last row with data in column G
lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row

' Filter data
ws.Range("G1").AutoFilter
ws.Range("$G$1:$G$" & lastRow).AutoFilter Field:=1, Criteria1:="=995915", _
    Operator:=xlOr, Criteria2:="=995925"
   
' Delete filtered data
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row

' Exit sub if no data to delete data (only header visible)
If lr = 1 Then Exit Sub

' Delete unhidden data
Application.DisplayAlerts = False
ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
Application.DisplayAlerts = True

' Unfilter data
ws.Range("G1").AutoFilter

Application.ScreenUpdating = True

End Sub

 

[howard]

Thanks for the help Joe