asked on

perform a quick delete of rows containing one of several different words

I need to be able to delete rows that 'do not' contain one of 5 different words. The spreadsheet contains several thousand rows so I am looking for a way to delete them quickly. I have this piece of code which deletes quickly but it deletes the rows containing the word, if I could change it to delete anything that is 'not equal' to these words it would be fine. Or a new macro :-)

Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(1, Cells(i, 2).Value, "ONE", 1) Or _
InStr(1, Cells(i, 2).Value, "TWO", 1) Or _
InStr(1, Cells(i, 2).Value, "THREE", 1) Or _
InStr(1, Cells(i, 2).Value, "FOUR", 1) Or _
InStr(1, Cells(i, 2).Value, "FIVE", 1) _
Then Cells(i, 2).EntireRow.Delete
Next i

Thanks

Barry Cunney

Hi
Do you wish the logic to be that it deletes rows that do not contain any one of the 5 words?

Jagwarman

ASKER

Yes I need it to delete rows that do not contain the 5 words

thanks

Barry Cunney

Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Not(InStr(1, Cells(i, 2).Value, "ONE", 1)) AND _
Not(InStr(1, Cells(i, 2).Value, "TWO", 1)) AND _
Not(InStr(1, Cells(i, 2).Value, "THREE", 1)) AND _
Not(InStr(1, Cells(i, 2).Value, "FOUR", 1)) AND _
Not(InStr(1, Cells(i, 2).Value, "FIVE", 1)) _
Then Cells(i, 2).EntireRow.Delete
Next i

Steve

You could try this which should be faster over a large data set (only one delete)

Sub stest()
    
    Dim rng As Range, rng1 As Range, rng2 As Range, DoDelete As Boolean, CurrCell As String
    
    Set rng = Intersect(ActiveSheet.UsedRange, Columns("B:B"))
    
    Set rng2 = Rows(Rows.Count & ":" & Rows.Count)

    For Each rng1 In rng
        
        DoDelete = True
        CurrCell = rng1.Value
        
        If InStr(CurrCell, "ONE") Then DoDelete = False
        If InStr(CurrCell, "TWO") Then DoDelete = False
        If InStr(CurrCell, "THREE") Then DoDelete = False
        If InStr(CurrCell, "FOUR") Then DoDelete = False
        If InStr(CurrCell, "FIVE") Then DoDelete = False
         
        If DoDelete Then Set rng2 = Union(rng2, Range(rng1.Address).EntireRow)

    Next rng1
    
    rng2.Delete
    
    MsgBox "Done"

End Sub

Open in new window

Jagwarman

ASKER

BCBUNNEY, it gets rid of everything. ???

Jagwarman

ASKER

The_Barman your solution locks my computer. It was running for 5 mins then locked.???

SOLUTION

Barry Cunney

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Steve

I am guessing you have a large number of rows?

How many do you have in the sheet?

Jagwarman

ASKER

over 30k

Steve

if you go to the bottom of the 30k then select all rows below that.
Then hit [CTRL]+[minus on num pad] (to delete all rows below the data)
Then re-run the macro.
The usedrange function can be a tad tempremental so may be seeing the whole sheet as "used"
Does this help?

Jagwarman

ASKER

BCUNNEY,

it does remove the rows but it keeps anything that is similar so if there is a word one it will keep that but it will also keep oneself

Steve

OR... pop this formula in any spare column:
=SUM(COUNTIF(B2,{"*ONE*","*TWO*","*THREE*","*FOUR*","*FIVE*"}))
Enter it using CTRL+SHIFT+ENTER
Then add a filter, filter to view Zero Values
Highlight all visible rows.
Hit [CTRL]+[minus on num pad] to delete all visible data.
Then unfilter.

Remove the * to get just the words:
=SUM(COUNTIF(B2,{"ONE","TWO","THREE","FOUR","FIVE"}))

Jagwarman

ASKER

The_Barman

still locking my PC unfortunately

Barry Cunney

please try the following

Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(1, Cells(i, 2).Value, " ONE ", 1) = 0 AND _
InStr(1, Cells(i, 2).Value, " TWO ", 1) = 0 AND _
InStr(1, Cells(i, 2).Value, " THREE ", 1) = 0 AND _
InStr(1, Cells(i, 2).Value, " FOUR ", 1) = 0 AND _
InStr(1, Cells(i, 2).Value, " FIVE ", 1) = 0_
Then Cells(i, 2).EntireRow.Delete
Next i

ASKER CERTIFIED SOLUTION

Steve

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Jagwarman

ASKER

thanks