Need help deleting rows based on cell criteria

[codys21]

Hi all,

So I have four columns of data and I am trying to delete entire rows based on a cell's value in a particular column. I need to do this for two columns (column B and column D in my data). The first column (B) I do it for works just fine and takes my data from 25397 rows down to 11715 rows. The second column (D) I do it for should bring it down from that 11715 to 1510 (these values will change every month which is why I am trying to use VBA.) Anyway, I pretty much copied and pasted from code from column B to column D, with only changing the name of the sub, the column it is looking at, and the values it will delete, but when I run it on column D, excel keeps loading and loading and eventually stops responding. Any ideas on why this is happening and how to fix it? I have attached the code I am using. I am not too experienced with VBA so I am using a modified version of some code I found online. The first sub deletes rows with values under 15 in column B, the second sub is suppose to delete rows with values under 0.05 in column D (I want to delete values with less than 5% in column D.)

Sub DeleteValuesUnder15()


Dim workrange As Range
Dim Firstrow As Integer
Dim Lastrow As Integer
Dim lrow As Integer


'Find first and last used row in column B
Range("B:B").Select
Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.Range("D1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row


'Loop through used cells backwards and delete if needed
For lrow = Lastrow To Firstrow Step -1
Set workrange = Cells(lrow, 2)
If workrange.Value < 15 _
Then workrange.EntireRow.Delete


Next lrow


End Sub



Sub DeletePercentUnder5()


Dim workrange As Range
Dim Firstrow As Integer
Dim Lastrow As Integer
Dim lrow As Integer


'Find first and last used row in column D
Range("D:D").Select
Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.Range("D1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row


'Loop through used cells backwards and delete if needed
For lrow = Lastrow To Firstrow Step -1
Set workrange = Cells(lrow, 3)
If workrange.Value < 0.05 _
Then workrange.EntireRow.Delete


Next lrow


End Sub


Thank you for any help!

 

[mumps]

Try:

Sub DelRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1:D1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=2, Criteria1:="<15", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=4, Criteria1:="<.05", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Selection.AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[JoeMo]

Hi all,

the second sub is suppose to delete rows with values under 0.05 in column D (I want to delete values with less than 5% in column D.)



Sub DeletePercentUnder5()


Dim workrange As Range
Dim Firstrow As Integer
Dim Lastrow As Integer
Dim lrow As Integer


'Find first and last used row in column D
Range("D:D").Select
Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.Range("D1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row


'Loop through used cells backwards and delete if needed
For lrow = Lastrow To Firstrow Step -1
Set workrange = Cells(lrow, 3)
If workrange.Value < 0.05 _
Then workrange.EntireRow.Delete


Next lrow


End Sub


Thank you for any help!

The bold red part above is referring to column C not column D. Change it to:

Cells(lrow,4)

or you could use:

Cells(lrow,"D")
as a better reminder that it's col D you want to scan for values less than 5%.

 

[codys21]

Try:

Sub DelRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1:D1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=2, Criteria1:="<15", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=4, Criteria1:="<.05", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Selection.AutoFilter
    Application.ScreenUpdating = True
End Sub

Perfect, thanks! The autofilter did it. Much better than going row by row.

 

[mumps]

My apologies. The macro in my previous post won't work properly. In order for the following macro to work, your data must start in row 2 with columns headers in row 1.

Sub DelRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=2, Criteria1:="<15", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$2:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
    ActiveSheet.Range("$A$1:$D$" & LastRow).AutoFilter Field:=4, Criteria1:="<.05", _
        Operator:=xlAnd
    ActiveSheet.Range("$A$1:$D$" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
    Application.ScreenUpdating = True
End Sub