Macro to Delete Rows (multiple criteria)

J

jakulski

New Member
Joined
Jan 17, 2017
Messages
15
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.
[TABLE="width: 918"]
<tbody>[TR]
[TD="align: center"]Lev
[/TD]
[TD="align: center"]SchID
[/TD]
[TD="align: center"]SchName
[/TD]
[TD="align: center"]ID
[/TD]
[TD="align: center"]FName
[/TD]
[TD="align: center"]LName
[/TD]
[TD="align: center"]Grade
[/TD]
[TD="align: center"]Gender
[/TD]
[TD="align: center"]Ethnic
[/TD]
[TD="align: center"]Elig
[/TD]
[/TR]
[TR]
[TD="align: center"]1
[/TD]
[TD="align: center"]1
[/TD]
[TD="align: center"]Happy Valley Elementary
[/TD]
[TD="align: center"]1234567
[/TD]
[TD="align: center"]Humpty
[/TD]
[TD="align: center"]Dumpty
[/TD]
[TD="align: center"]3
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]2
[/TD]
[TD="align: center"]2
[/TD]
[TD="align: center"]Rolling Meadow Middle
[/TD]
[TD="align: center"]2345671
[/TD]
[TD="align: center"]Tom
[/TD]
[TD="align: center"]Cat
[/TD]
[TD="align: center"]8
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]3
[/TD]
[TD="align: center"]3
[/TD]
[TD="align: center"]Tuckman County High
[/TD]
[TD="align: center"]3456712
[/TD]
[TD="align: center"]Jerry
[/TD]
[TD="align: center"]Maguire
[/TD]
[TD="align: center"]10
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]4
[/TD]
[TD="align: center"]2
[/TD]
[TD="align: center"]Rolling Thunder Middle
[/TD]
[TD="align: center"]4567123
[/TD]
[TD="align: center"]Buzz
[/TD]
[TD="align: center"]Light-Year
[/TD]
[TD="align: center"]8
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]5
[/TD]
[TD="align: center"]4
[/TD]
[TD="align: center"]Tuckman County Middle
[/TD]
[TD="align: center"]5671234
[/TD]
[TD="align: center"]Peter
[/TD]
[TD="align: center"]Brady
[/TD]
[TD="align: center"]7
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]6
[/TD]
[TD="align: center"]5
[/TD]
[TD="align: center"]John Glenn High
[/TD]
[TD="align: center"]6712345
[/TD]
[TD="align: center"]John
[/TD]
[TD="align: center"]Glenn
[/TD]
[TD="align: center"]12
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Possibly one way (loosely tested only)...
Make sure you test on a copy of your data as you are deleting.

Code: 
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.
 
Last edited:
Upvote 0
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.

Code: 
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
 
Upvote 0
If you can use the SchID rather than the SchName
How about
Code: 
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
 
Upvote 0
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!
 
Upvote 0
MARK858 said:
Possibly one way (loosely tested only)...
Make sure you test on a copy of your data as you are deleting.

Code: 
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.
Click to expand...


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!
 
Upvote 0
I need to add six more schools but the curser stops
Click to expand...

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.
 
Upvote 0
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.
 
Upvote 0
Code: 
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
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
VBA code to look in multiple sheets, multiple columns, delete rows from one sheet
Replies
9
Views
1K
jolivanes
jolivanes
O
  • Question Question
VBA Code for a Function to Delete Duplicate Rows based on Multiple Column Criteria
Replies
0
Views
3K
OilEconomist
O
N
  • Question Question
How Do I Delete Pictures and Text from Cell Ranges of Multiple Columns?
Replies
8
Views
910
njpamdnc
N
M
  • Question Question
VBA Help: Transpose data from duplicate rows to new columns
Replies
8
Views
5K
Joe4
Joe4
G
  • Solved
VBA to delete rows based on multiple criteria in multiple columns
2
Replies
18
Views
8K
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,823
Messages
6,181,175
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top