CODEWITHSUNDEEP
vbaexceloptimization
OutOfMemory
OutOfMemory

Reputation: 37

Delete rows with one specific column blank

I made a code that will search in all rows of my table (table1) and when in a certain column find a blank cell, that row will be copy for another table (table2) and erased from table1. When I put the code running the vb stays "Not running" and I need force the stop, but when I look the tables in excel I see that he copy some rows (not delete because I force the stop before he get there). I do this in a table with 95k rows and it took a much time and I need do that fast. So here's the code:

Function DeleteRows() 

Debug.Print Time        
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim lRow As Long, Row As Long
Dim rw As Range, rngDel As Range

Application.ScreenUpdating = False
viewmode = ActiveWindow.View
ActiveWindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Row = 2
lRow = Range("A" & Rows.Count).End(xlUp).Row
Set shtSrc = Worksheets("Sheet3")
Set shtDest = Worksheets("Sheet2")
shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1")

For i = 2 To lRow

    Set rw = shtSrc.Rows(i)

    If (rw.Cells(42).Value = "") Then
        rw.Copy shtDest.Rows(Row)
        AddToRange rngDel, rw
        Row = Row + 1
    End If

Next i

If Not rngDel Is Nothing Then
    rngDel.Delete
End If

Application.DisplayStatusBar = True
ActiveWindow.View = viewmode
Application.ScreenUpdating = False
Debug.Print Time

End Function

'utility sub for building up a range
Sub AddToRange(rngTot, rng)
    If rngTot Is Nothing Then
        Set rngTot = rng
    Else
        Set rngTot = Application.Union(rng, rngTot)
    End If
End Sub

Upvotes: 0

Views: 64

Answers (1)

neuralgroove
neuralgroove

Reputation: 580

Autofilter is a much quicker way to go about this than iteration, I ran the following code on 100,000 rows with 42 fields in 2 seconds. You end up with two new sheets, one with the rows you moved (blank value in column 42) and another with the rows you kept, your source sheet is left untouched.

Const SourceSheetName As String = "Sheet3"
Const ColumnToCheckForBlanks As Long = 42

Dim shtSrc As Worksheet

Sub sortanddelete()
    On Error GoTo errorhandler
    Debug.Print "START-->"; Now()
    Set shtSrc = Sheets(SourceSheetName)
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    FilterAndCopy shtSrc, "Deleted Rows", "="
    FilterAndCopy shtSrc, "Kept Rows", "<>"
    GoTo cleanup
errorhandler:
    MsgBox Err.Number & "-->" & Err.Description, vbCritical, "Error"
cleanup:
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Debug.Print "END  -->" & Now()
End Sub

Sub FilterAndCopy(shtSrc As Worksheet, destSheetName As String, Criteria As String)
    Dim DestSheet As Worksheet
    DelIfSheetExists destSheetName
    shtSrc.UsedRange.AutoFilter Field:=ColumnToCheckForBlanks, Criteria1:=Criteria
    shtSrc.UsedRange.Copy
    Set DestSheet = Sheets.Add(After:=shtSrc)
    DestSheet.Name = destSheetName
    DestSheet.Paste
End Sub

Sub DelIfSheetExists(SheetName As String)
    On Error GoTo errorhandler
    Worksheets(SheetName).Delete
    Exit Sub
errorhandler:
    Err.Clear
End Sub

Results:

START-->06/11/2015 9:13:13 AM 
END  -->06/11/2015 9:13:15 AM

Upvotes: 1

Related Questions