Macro to Delete Rows (multiple criteria)

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

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
11,469
Office Version
365, 2010
Platform
Windows, Mobile
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:

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,807
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,050
Office Version
365
Platform
Windows
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
 

jakulski

New Member
Joined
Jan 17, 2017
Messages
15
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

New Member
Joined
Jan 17, 2017
Messages
15
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.

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

MrExcel MVP
Joined
Nov 12, 2010
Messages
11,469
Office Version
365, 2010
Platform
Windows, Mobile
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

New Member
Joined
Jan 17, 2017
Messages
15
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

MrExcel MVP
Joined
Nov 12, 2010
Messages
11,469
Office Version
365, 2010
Platform
Windows, Mobile
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
 

jakulski

New Member
Joined
Jan 17, 2017
Messages
15
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.
 

Forum statistics

Threads
1,081,676
Messages
5,360,441
Members
400,586
Latest member
Minty

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top