Delete row if the column contains text - vba

Question

I known, this question has been asked thousands of times. But every time I picked up a solution appears error when i debug. (error 1004)
I work with a database with about 300000 lines, where more than half do not care. (I know that have filter, but wanted to erase to reduce the file and speed up the process).
Then if the column M has a keyword like "water", "beer" or "vodka" it will delete the row. I mean, don't need to be the exact word, just the keyword.
OBS: Row 1 it's a table title with the frozen line.
Thanks!

Answer 1

The following code works less than 4 seconds for processing your sample data on my machine:
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet, Data As Range
Dim Sheet_Name As String, Text As String, Water As Long, Beer As Long, Vodka As Long
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("SOVI")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Output(1 To LastRow - 1, 1 To 1) As Long
For i = 1 To LastRow - 1
Text = Cells(i + 1, 13)
Water = InStr(Text, "water")
Beer = InStr(Text, "beer")
Vodka = InStr(Text, "vodka")
If Water > 0 Or Beer > 0 Or Vodka > 0 Then Output(i, 1) = 1
Next
[S2].Resize(LastRow - 1, 1) = Output
LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range(Cells(1, 1), Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=19, Criteria1:="=1"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
NewSheet_Data.Columns(19).Clear
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub

Answer 2

In the future, please post code you've tried first for the community to help you out. That being said, try this out:
Sub Test()
Dim x as Long
Dim i as Long
x = Sheets("SOVI").Range("M" & Rows.Count).End(xlUp).Row
For i = x to 2 Step -1
If InStr(1, Range("M" & i).Value, "water", vbTextCompare) Or InStr(1, Range("M" & i).Value, "beer", vbTextCompare) Or InStr(1, Range("M" & i).Value, "vodka", vbTextCompare) Then
Range("M" & i).entirerow.delete
End If
Next i
End Sub

Answer 3

I would use a slightly different approach, with the Like and with Select Case - this will give you more versatility in the future if you would want to expand it to more types of drinks.
Sub FindDrink()
Dim lRow As Long
Dim i As Long
Dim sht As Worksheet
' always set your sht, modify to your sheet name
Set sht = ThisWorkbook.Sheets("Sheet1")
lRow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
For i = lRow To 2 Step -1
Select Case True
Case (sht.Cells(i, "M").Value Like "*beer*") Or (sht.Cells(i, "M").Value Like "*water*") Or (sht.Cells(i, "M").Value Like "*vodka*")
Range("M" & i).EntireRow.Delete
Case Else
' if you decide to do other things in the future for other values
End Select
Next i
End Sub

Answer 4

use excel built in filtering functions for the maximum speed
Autofilter
Option Explicit
Sub main()
Dim keysToErase As Variant, key As Variant
keysToErase = Array("water", "beer", "vodka") '<--| list your keywords to delete matching column "M" rows with
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
For Each key In keysToErase '<--| loop through keys
.AutoFilter field:=13, Criteria1:="*" & key & "*" '<--| filter column "M" with key
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
Next key
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
AdvancedFilter
Option Explicit
Sub main2()
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("U1:U4") '<--| this filters on all keys you placed in cells "U2:U4" with cell "U1" with wanted data header
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub

Answer 5

Try with Below code
Sub test()
Application.DisplayAlerts = False
Dim lastrow As Long
Dim i As Long
Dim currentrng As Range
lastrow = Range("M" & Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
Set currentrng = Range("M" & i)
If ((currentrng Like "*water*") Or (currentrng Like "*beer*") Or (currentrng Like "*vodka*")) Then
currentrng.EntireRow.Delete shift:=xlUp
End If
Next i
Application.DisplayAlerts = True
End Sub