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:


[TABLE="width: 500"]
<tbody>[TR]
[TD]A1[/TD]
[TD]B1[/TD]
[TD]C1[/TD]
[TD]D1[/TD]
[TD]E1[/TD]
[TD]F1[/TD]
[TD]G1[/TD]
[TD]H1[/TD]
[TD]I1[/TD]
[TD]J1[/TD]
[TD]K1[/TD]
[/TR]
[TR]
[TD]John Smith[/TD]
[TD]English[/TD]
[TD]40%[/TD]
[TD]Math[/TD]
[TD]60%[/TD]
[TD]Science[/TD]
[TD]20%[/TD]
[TD]Art[/TD]
[TD]70%[/TD]
[TD]History[/TD]
[TD]80%[/TD]
[/TR]
</tbody>[/TABLE]




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.