Macro to Delete Rows (multiple criteria)

[jakulski]

I have a worksheet consisting of approximately 50,000 rows and 30 columns (A - AD). Each column has a heading. I need a macro that will quickly delete all rows that don't contain specific text in Column C. Column C will have names of schools, elementary, middle, and high. There are approximately 225 different school options to go in each row in Column C. For each macro, I will designate 35-45 schools to keep, with all other rows being deleted. ols. Let's say that for this example, I would like to keep all rows that contain any one of the following schools in Column C (SchName): Happy Valley Elementary; Rolling Thunder Middle; Betsy Ross High; and John Glenn High.

Lev	SchID	SchName	ID	FName	LName	Grade	Gender	Ethnic	Elig
1	1	Happy Valley Elementary	1234567	Humpty	Dumpty	3
2	2	Rolling Meadow Middle	2345671	Tom	Cat	8
3	3	Tuckman County High	3456712	Jerry	Maguire	10
4	2	Rolling Thunder Middle	4567123	Buzz	Light-Year	8
5	4	Tuckman County Middle	5671234	Peter	Brady	7
6	5	John Glenn High	6712345	John	Glenn	12

<tbody>
</tbody>

 

[MARK858]

Possibly one way (loosely tested only)...
Make sure you test on a copy of your data as you are deleting.

Sub DelSchl()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False

    LR = Range("C" & Rows.Count).End(xlUp).Row

    Range("A:A").Insert

    For i = LR To 2 Step -1
        If Not IsError(Application.Match(Range("D" & i).Value, _
                                         Array("Happy Valley Elementary", "Rolling Thunder Middle", "Betsy Ross High", "John Glenn High"), 0)) Then Cells(i, 1) = 1
    Next i

    With Intersect(ActiveSheet.UsedRange, Rows(2).Resize(LR - 1))
        .Sort .Cells(1), 1, Header:=xlNo
        Range(Rows(.Cells(.Rows.Count, 1).End(3)(2).Row), .Rows(.Rows.Count)).Delete
    End With

    Range("A:A").Delete

    Application.ScreenUpdating = True
End Sub

Not sure how fast it will be as not tested.

 

[ranman256]

youll have 2 sheets:
sheet1: (yours above) of the entire data list with some to be removed.
List2Keep: the list of only the names to keep

the code loads the keep list, then runs thru the entire list (sheet1, name it what you will) and marks it for deletion.
then filter the 'deletes' and press delete key.

Public Sub Mark2Keep()
Dim colKeep As New Collection
Dim sNam As String
Dim bMarkIT As Boolean


On Error GoTo errMark


   'load sheets to keep
Sheets("List2keep").Activate
Range("a1").Select
While ActiveCell.Value <> ""
   sNam = ActiveCell.Value
   colKeep.Add sNam, sNam
   ActiveCell.Offset(1, 0).Select   'next row
Wend


   'now go thru list mark those to delete
Sheets("SHEET1").Activate
Range("d2").Select
While ActiveCell.Value <> ""
   sNam = ActiveCell.Value
   bMarkIT = colKeep(sNam) <> sNam
   If bMarkIT Then ActiveCell.Value = "delete"
   
   ActiveCell.Offset(1, 0).Select   'next row
Wend


Exit Sub
errMark:
If Err = 5 Then
  bMarkIT = True
  Resume Next
End If
MsgBox Err.Description, , Err
End Sub

 

[Fluff]

If you can use the SchID rather than the SchName
How about

Sub Fltr_Del()

    ActiveSheet.Range("$A$1:$K$280").AutoFilter Field:=2, Criteria1:="<5", _
        Operator:=xlOr, Criteria2:=">10"
    Range("A2", Range("A" & Rows.Count).End(xlUp)).EntireRow.Delete
    ActiveSheet.Range("A1").AutoFilter

End Sub

 

[jakulski]

Mark858, this worked perfectly EXCEPT that it seems I can't add all of the schools to the Array. I need to add six more schools but the curser stops and doesn't let me continue. Suggestions? Thank you in advance!

 

[jakulski]

Possibly one way (loosely tested only)...
Make sure you test on a copy of your data as you are deleting.

Sub DelSchl()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False

    LR = Range("C" & Rows.Count).End(xlUp).Row

    Range("A:A").Insert

    For i = LR To 2 Step -1
        If Not IsError(Application.Match(Range("D" & i).Value, _
                                         Array("Happy Valley Elementary", "Rolling Thunder Middle", "Betsy Ross High", "John Glenn High"), 0)) Then Cells(i, 1) = 1
    Next i

    With Intersect(ActiveSheet.UsedRange, Rows(2).Resize(LR - 1))
        .Sort .Cells(1), 1, Header:=xlNo
        Range(Rows(.Cells(.Rows.Count, 1).End(3)(2).Row), .Rows(.Rows.Count)).Delete
    End With

    Range("A:A").Delete

    Application.ScreenUpdating = True
End Sub

Not sure how fast it will be as not tested.

Mark858, this worked perfectly EXCEPT that it seems I can't add all of the schools to the Array. I need to add six more schools but the curser stops and doesn't let me continue. Suggestions? Thank you in advance!

 

[MARK858]

I need to add six more schools but the curser stops

I don't know what you mean by the cursor stops, post the schools you want added.
I will also post some code to use a range with the schools.

 

[jakulski]

When completing this line, "Array("Happy Valley Elementary", "Rolling Thunder Middle",......."), 0)) Then Cells(I, 1) = 1", it's as if I have reached a maximum ceiling of characters -I can't add anything more. Not sure why unless there is a character limit.

 

[MARK858]

Sub DelSchl()
    Dim LR As Long, i As Long
    Application.ScreenUpdating = False

    LR = Range("C" & Rows.Count).End(xlUp).Row

    Range("A:A").Insert

    For i = LR To 2 Step -1
        If Not IsError(Application.Match(Range("D" & i).Value, _
                                         Array("Happy Valley Elementary", "Rolling Thunder Middle", "Betsy Ross High", "John Glenn High", _
                                         "aaaaaa", "bbbbbb", "ccccccc", "ddddddd", "eeeeee", "fffffffffff", "ggggggggg", "hhhhhhhh", "iiiiiiiii", _
                                         "jjjjjjjj", "kkkkkkkkk", "llllllllll", "mmmmmmmm", "nnnnnnnnnn", "oooooooo", "ppppppp", "qqqqqqqq", _
                                         "rrrrrrrr", "sssssssssss", "tttttttttt", "uuuuuuuuuu", "vvvvvvvvv", "wwwwwwwwwwwww", "xxxxxxxxxx", _
                                         "yyyyyy", "zzzzzzzzz"), 0)) Then Cells(i, 1) = 1
    Next i

    With Intersect(ActiveSheet.UsedRange, Rows(2).Resize(LR - 1))
        .Sort .Cells(1), 1, Header:=xlNo
        Range(Rows(.Cells(.Rows.Count, 1).End(3)(2).Row), .Rows(.Rows.Count)).Delete
    End With

    Range("A:A").Delete

    Application.ScreenUpdating = True
End Sub

 

[jakulski]

Ugh...! I now have all of the schools added back in, but the entire three lines are red, starting with "If Not IsError..." until "...Then Cells(I, 1) =1". Any more suggestions? I have appreciated your help so far, Mark858.