Macro - end of range is unknown (varies)

[gomes123]

I have an excel macro to filter and delete rows based on some criteria. It works, but sometimes the last row changes.

So I've just put it as 9999, but sometimes the last row could be more than 9999. Is there a way to improve the code? Thanks!

Sub Macro3()
With Worksheets("Sheet1")
     .Range("M1:M9999").AutoFilter 1, "<100000"
     .Range("M2:M9999").SpecialCells(xlCellTypeVisible).EntireRow.Delete
     .AutoFilterMode = False
     
          .Range("J1:J9999").AutoFilter 1, "<30"
     .Range("J2:J9999").SpecialCells(xlCellTypeVisible).EntireRow.Delete
     .AutoFilterMode = False
     
     
               .Range("c1:C9999").AutoFilter 1, "<=0.3"
     .Range("C2:C9999").SpecialCells(xlCellTypeVisible).EntireRow.Delete
     .AutoFilterMode = False
     
End With
End Sub

 

[kevin9999]

Does your data start in column A?

 

[kevin9999]

Try the following on a copy of your data (assumes the figures in columns C, J and M are numbers & not text)

Option Explicit
Sub Delete_Rows_Multi_Criteria()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    Dim LRow As Long, LCol As Long, i As Long, a, b
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    a = Range(ws.Cells(2, 3), ws.Cells(LRow, 13))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If a(i, 1) <= 0.3 Or a(i, 8) < 30 Or a(i, 11) < 100000 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

 

[gomes123]

Does your data start in column A?

Thanks. Yes, the data starts from column A to N. From row 2. Row 1 is the headers.

 

[gomes123]

Try the following on a copy of your data (assumes the figures in columns C, J and M are numbers & not text)

Option Explicit
Sub Delete_Rows_Multi_Criteria()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    Dim LRow As Long, LCol As Long, i As Long, a, b
    LRow = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
   
    a = Range(ws.Cells(2, 3), ws.Cells(LRow, 13))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If a(i, 1) <= 0.3 Or a(i, 8) < 30 Or a(i, 11) < 100000 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

Thanks! This works, most appreciated!

 

[kevin9999]

Thanks! This works, most appreciated!

Happy to help and thanks for the feedback