VBA code to search for a range of percentages and delete corresponding cells

[butternaut]

Hello,


I have an Excel sheet for students' marks. I need to remove the class(es) and mark(s) that are passing (mark of 50-100%). Here is how my Excel sheet is set up:

A1	B1	C1	D1	E1	F1	G1	H1	I1	J1	K1
John Smith	English	40%	Math	60%	Science	20%	Art	70%	History	80%

<tbody>
</tbody>

John is failing 2 classes (mark of 49% or less). I want to be able to remove the other 3 classes he is passing (along with the grade for that class) and just leave the failing class's names and respective failing marks.


Ideally, I would also like to be able to remove the entire row for any students who are not failing anything, but I can live without it.


If anyone has any thoughts, I'd greatly appreciate it.


Thanks very much in advance!

 

[mumps]

Assuming you have headers in row 1 in all used columns and your data starts in row 2, try this macro:

Sub butternaut()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim lColumn As Long
    lColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Dim counter As Boolean
    counter = True
    Dim x As Long
    Dim y As Long
    Dim rng As Range
    For x = LastRow To 2 Step -1
        For y = 3 To lColumn Step 2
            If Cells(x, y) < 0.5 Then
                Range(Cells(x, y - 1), Cells(x, y)).ClearContents
            End If
        Next y
    Next x
    For x = LastRow To 2 Step -1
        For y = 3 To lColumn Step 2
            If Cells(x, y) < 0.5 Then
                counter = False
                Exit For
            End If
        Next y
        If counter = True Then
            Rows(x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[butternaut]

Assuming you have headers in row 1 in all used columns and your data starts in row 2, try this macro:

Sub butternaut()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim lColumn As Long
    lColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Dim counter As Boolean
    counter = True
    Dim x As Long
    Dim y As Long
    Dim rng As Range
    For x = LastRow To 2 Step -1
        For y = 3 To lColumn Step 2
            If Cells(x, y) < 0.5 Then
                Range(Cells(x, y - 1), Cells(x, y)).ClearContents
            End If
        Next y
    Next x
    For x = LastRow To 2 Step -1
        For y = 3 To lColumn Step 2
            If Cells(x, y) < 0.5 Then
                counter = False
                Exit For
            End If
        Next y
        If counter = True Then
            Rows(x).EntireRow.Delete
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

Hi mumps,

I really appreciate you helping me out, but unfortunately, it's backwards... it removes the failing classes, and I need it to remove the passing classes. Could you please let me know what I should change?

Thanks!!

 

[mumps]

Change the first < to >.

 

[butternaut]

That did it!! Thank you so very much- you have saved me a ton of time!!

 

[mumps]

My pleasure.