Efficient way to delete entire row if cell doesn't contain '@'

Question

I'm creating a fast sub to do a validity check for emails. I want to delete entire rows of contact data that do not contain a '@' in the 'E' Column. I used the below macro, but it operates too slowly because Excel moves all the rows after deleting.

I've tried another technique like this: set rng = union(rng,c.EntireRow), and afterwards deleting the entire range, but I couldn't prevent error messages.

I've also experimented with just adding each row to a selection, and after everything was selected (as in ctrl+select), subsequently deleting it, but I could not find the appropriate syntax for that.

Any ideas?

Sub Deleteit()
    Application.ScreenUpdating = False

    Dim pos As Integer
    Dim c As Range

    For Each c In Range("E:E")

        pos = InStr(c.Value, "@")
        If pos = 0 Then
            c.EntireRow.Delete
        End If
    Next

    Application.ScreenUpdating = True
End Sub

Answer 1

You don't need a loop to do this. An autofilter is much more efficient. (similar to cursor vs. where clause in SQL)

Autofilter all rows that don't contain "@" and then delete them like this:

Sub KeepOnlyAtSymbolRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long

    Set ws = ActiveWorkbook.Sheets("Sheet1")

    lastRow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row

    Set rng = ws.Range("E1:E" & lastRow)

    ' filter and delete all but header row
    With rng
        .AutoFilter Field:=1, Criteria1:="<>*@*"
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ' turn off the filters
    ws.AutoFilterMode = False
End Sub

NOTES:

• .Offset(1,0) prevents us from deleting the title row
• .SpecialCells(xlCellTypeVisible) specifies the rows that remain after the autofilter has been applied
• .EntireRow.Delete deletes all visible rows except for the title row

Step through the code and you can see what each line does. Use F8 in the VBA Editor.

Answer 2

Have you tried a simple auto filter using "@" as the criteria then use

specialcells(xlcelltypevisible).entirerow.delete

note: there are asterisks before and after the @ but I don't know how to stop them being parsed out!

Answer 3

Using an example provided by user shahkalpesh, I created the following macro successfully. I'm still curious to learn other techniques (like the one referenced by Fnostro in which you clear content, sort, and then delete). I'm new to VBA so any examples would be very helpful.

   Sub Delete_It()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

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

    With ActiveSheet
        .Select
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        .DisplayPageBreaks = False

        'Firstrow = .UsedRange.Cells(1).Row
        Firstrow = 2
        Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row

        For Lrow = Lastrow To Firstrow Step -1
            With .Cells(Lrow, "E")
                If Not IsError(.Value) Then
                    If InStr(.Value, "@") = 0 Then .EntireRow.Delete
                End If
            End With
         Next Lrow
        End With

    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub

Answer 4

When you are working with many rows and many conditions, you better off using this method of row deletion

Option Explicit

Sub DeleteEmptyRows()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim i&, lr&, rowsToDelete$, lookFor$

    '*!!!* set the condition for row deletion
    lookFor = "@"

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lr = ws.Range("E" & Rows.Count).End(xlUp).Row

    ReDim arr(0)

    For i = 1 To lr
     If StrComp(CStr(ws.Range("E" & i).Text), lookFor, vbTextCompare) = 0 then
       ' nothing
     Else
        ReDim Preserve arr(UBound(arr) + 1)
        arr(UBound(arr) - 1) = i
     End If
    Next i

    If UBound(arr) > 0 Then
        ReDim Preserve arr(UBound(arr) - 1)
        For i = LBound(arr) To UBound(arr)
            rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
        Next i

        ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Delete Shift:=xlUp
    Else
        Application.ScreenUpdating = True
        MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
        Exit Sub
    End If

    If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
    Set ws = Nothing
End Sub

Answer 5

Instead of looping and referencing each cell 1 by 1, grab everything and put it into a variant array; Then loop the variant array.

Starter:

Sub Sample()
    ' Look in Column D, starting at row 2
    DeleteRowsWithValue "@", 4, 2
End Sub

The Real worker:

Sub DeleteRowsWithValue(Value As String, Column As Long, StartingRow As Long, Optional Sheet)
Dim i As Long, LastRow As Long
Dim vData() As Variant
Dim DeleteAddress As String

    ' Sheet is a Variant, so we test if it was passed or not.
    If IsMissing(Sheet) Then Set Sheet = ActiveSheet
    ' Get the last row
    LastRow = Sheet.Cells(Sheet.Rows.Count, Column).End(xlUp).Row
    ' Make sure that there is work to be done
    If LastRow < StartingRow Then Exit Sub

    ' The Key to speeding up the function is only reading the cells once 
    ' and dumping the values to a variant array, vData
    vData = Sheet.Cells(StartingRow, Column) _
                 .Resize(LastRow - StartingRow + 1, 1).Value
    ' vData will look like vData(1 to nRows, 1 to 1)
    For i = LBound(vData) To UBound(vData)
        ' Find the value inside of the cell
        If InStr(vData(i, 1), Value) > 0 Then
            ' Adding the StartingRow so that everything lines up properly
            DeleteAddress = DeleteAddress & ",A" & (StartingRow + i - 1)
        End If
    Next
    If DeleteAddress <> vbNullString Then
        ' remove the first ","
        DeleteAddress = Mid(DeleteAddress, 2)
        ' Delete all the Rows
        Sheet.Range(DeleteAddress).EntireRow.Delete
    End If
End Sub