Delete Rows When a Column Does Not Contain Value

Question

Hi, I want to delete all rows in a very large spreadsheet when a row does not contain a specific value. I found the code below on a web site but it is incredibly slow. Is there a way to change the code to make it run much faster? I thank you for your help.

Sub DelRowsNotContainCertainText()
    Set myRange = Application.Selection
    Set myRange = Application.InputBox("Select one Range which contain texts that you want to delete rows based on", "DelRowsNotContainCertainText", myRange.Address, Type:=8)
    cText = Application.InputBox("Please type a certain text", "DelRowsNotContainCertainText", "", Type:=2)
    For i = myRange.Rows.Count To 1 Step -1
        Set myRow = myRange.Rows(i)
        Set myCell = myRow.Find(cText, LookIn:=xlValues)
        If myCell Is Nothing Then
           myRow.Delete
        End If
    Next
End Sub

Answer 1

Sub Test4()

Dim Conn As Object, Rst As Object

Dim strConn As String, strSQL As String

Dim i As Integer, PathStr As String

Set Conn = CreateObject("ADODB.Connection")

Set Rst = CreateObject("ADODB.Recordset")

PathStr = ThisWorkbook.FullName   '

Select Case Application.Version \* 1    '

Case Is <= 11

    strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr

Case Is >= 12

    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""

End Select

'here set your sql to select rows not contain cText in column cText\_col

strSQL = "select \* [sheet1$] where [cTxt\_column\_first]  not like '%" & cText & %"''

Conn.Open strConn    '

Set Rst = Conn.Execute(strSQL)    '

With Sheet3

    .Cells.Clear

    For i = 0 To Rst.Fields.Count - 1    '

        .Cells(1, i + 1) = Rst.Fields(i).Name

    Next i

    .Range("A2").CopyFromRecordset Rst

    .Cells.EntireColumn.AutoFit  '

    .Cells.EntireColumn.AutoFit  '

End With

Rst.Close    '

Conn.Close

Set Conn = Nothing

Set Rst = Nothing

End Sub

Answer 2

re: slow to execute

I've modified the code.

The main changes are two...

ScreenUpdating is turned off.

Application.Intersect is used to eliminate blank rows when entire columns are selected.

'---

Sub DelRowsNotContainCertainText_R1()
'Nothing Left to Lose - January 2022
On Error GoTo NotRight
Dim MyRange As Excel.Range, MyCell As Excel.Range
Dim cText As Variant, i As Long

cText = Range("C2").Value '<<<<<<<<< NOTE
On Error Resume Next
Set MyRange = Application.InputBox(Prompt:= _

"Select a Range which contains the text in Cell B2. " & vbCr & _

"All rows in the selection that do not contain that text will be deleted. ", _

Title:=cText & " is the item. ", Type:=8)
On Error GoTo NotRight
If MyRange Is Nothing Then Exit Sub

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set MyRange = Application.Intersect(MyRange, MyRange.Parent.UsedRange)
For i = MyRange.Rows.Count To 1 Step -1
Set MyCell = MyRange.Rows(i).Find(cText, LookIn:=xlValues)
If MyCell Is Nothing Then
MyRange.Rows(i).Delete shift:=xlShiftUp
End If
Next

NotRight:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

'---

Nothing Left to Lose

Answer 3

Try this:

Sub DelRowsNotContainCertainText()
Dim myRange As Range
Dim cText As String
Dim myRow As Range
Dim myCell As Range
Dim i As Long
Dim delRange As Range
Set myRange = Application.InputBox("Select one Range which contain texts that you want to delete rows based on", "DelRowsNotContainCertainText", Selection.Address, Type:=8)
cText = Application.InputBox("Please type a certain text", "DelRowsNotContainCertainText", "", Type:=2)
For i = 1 To myRange.Rows.Count
Set myRow = myRange.Rows(i)
Set myCell = myRow.Find(cText, LookIn:=xlValues)
If myCell Is Nothing Then
If delRange Is Nothing Then
Set delRange = myRow
Else
Set delRange = Union(myRow, delRange)
End If
End If
Next i
If Not delRange Is Nothing Then
delRange.Delete Shift:=xlShiftUp
End If
End Sub