如果该列包含文本，则删除行

我知道，这个问题已经被问过几千次了。 但每当我拿起一个解决scheme出现错误，当我debugging。 （错误1004）

我使用的数据库大约有30万行，其中一半以上不关心。 （我知道有filter，但想擦除，以减less文件，加快进程）。

那么如果M列有一个像“水”，“啤酒”或“伏特加”这样的关键字，就会删除该行。 我的意思是，不需要是确切的词，只是关键字。

OBS：第1行是一个带有冻结行的表格标题。

谢谢！

Answer 1

以下代码在我的机器上处理您的示例数据的时间less于4秒。

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

在将来，请张贴你已经尝试过的代码，以便社区帮助你。 这就是说，试试这个：

 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

我会用一个稍微不同的方法，用Like和Select Case – 如果你想把它扩展到更多types的饮料，这将给你在将来更多的多function性。

 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

使用内置的过滤function的Excel的最高速度

自动筛选

 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

尝试使用下面的代码

 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