faster deletion of rows

Question

the code below allows me to delete rows if a cells contains certain values. now for some reason it takes me a lot of time(30 mins and counting).

' to delete data not meeting criteria
                Worksheets("Dashboard").Activate
                n1 = Range("n1")
                n2 = Range("n2")
                Worksheets("Temp Calc").Activate
                lastrow = Cells(Rows.Count, 1).End(xlUp).Row
                For z = lastrow To 2 Step -1
                If Cells(z, 6).Value = "CNF" Or Cells(z, 4).Value <= n1 Or Cells(z, 3).Value >= n2 Then
                Rows(z).Delete
                End If
                Next z

a google search and some talk with forum member sam provided me with two options

to use filter.(i do want to use this).

using arrays to store the entire worksheet and then copy data that only matches my criteria.He was kind enough to help me come up with the following code.But i am not familiar with working on data in an array.

lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Column.Count).End(xlRight).Row
arr1 = Range("A1:Z" & lastrow)
ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))
j = j + 1
For i = 1 To UBound(arr1, 1)
If arr1(i, 6) <> "CNF" And arr1(i, 4) > n1 And arr1(i, 3) < n2 Then
For k = 1 To lastCol
    arr2(j, k) = arr1(i, k)
Next k
j = j + 1
End If
Next i


Range(the original bounds) = arr2

my question is is there a faster way of deleting rows in an array other than the ones mentioned above? Or is array or filter the best options i've got.I am open to suggestions.

Update my new code looks like this. it does not filter the date rangeeven if they are hardcoded can anybody tell me what i am doing wrong ?

Option Explicit 

Sub awesome() 
Dim Master As Workbook 
Dim fd As FileDialog 
Dim filechosen As Integer 
Dim i As Integer 
Dim lastrow, x As Long 
Dim z As Long 
Application.ScreenUpdating = False 
Dim sngStartTime As Single 
Dim sngTotalTime As Single 
Dim ws As Worksheet 
Dim FltrRng As Range 
Dim lRow As Long 
Dim N1 As Date, N2 As Date 

sngStartTime = Timer 
Sheets("Dashboard").Select 
N1 = Range("n1").Value 
N2 = Range("n2").Value 
Sheets("Temp Calc").Select 

'Clear existing sheet data except headers 
'Sheets("Temp Calc").Select 
'Rows(1).Offset(1, 0).Resize(Rows.Count - 1).ClearContents 

'The folder containing the files to be recap'd 
Set fd = Application.FileDialog(msoFileDialogFilePicker) 
fd.InitialFileName = "G:\Work\" '<----- Change this to where the files are stored. 
fd.InitialView = msoFileDialogViewList 
'allow multiple file selection 
fd.AllowMultiSelect = True 
fd.Filters.Add "Excel Files", "*.xls*" 
filechosen = fd.Show 
'Create a workbook for the recap report 
Set Master = ThisWorkbook 
If filechosen = -1 Then 

'open each of the files chosen 
For i = 1 To fd.SelectedItems.Count 
Workbooks.Open fd.SelectedItems(i) 
With ActiveWorkbook.Worksheets(1) 
Range("O2", Range("O" & Cells(Rows.Count, "O").End(xlUp).Row)).Copy Master.Worksheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
Range("p2", Range("P" & Cells(Rows.Count, "P").End(xlUp).Row)).Copy Master.Worksheets(2).Range("B" & Rows.Count).End(xlUp).Offset(1, 0) 
Range("Q2", Range("Q" & Cells(Rows.Count, "Q").End(xlUp).Row)).Copy Master.Worksheets(2).Range("C" & Rows.Count).End(xlUp).Offset(1, 0) 
Range("R2", Range("R" & Cells(Rows.Count, "R").End(xlUp).Row)).Copy Master.Worksheets(2).Range("D" & Rows.Count).End(xlUp).Offset(1, 0) 
Range("A2", Range("A" & Cells(Rows.Count, "A").End(xlUp).Row)).Copy Master.Worksheets(2).Range("E" & Rows.Count).End(xlUp).Offset(1, 0) 
Range("AC2", Range("AC" & Cells(Rows.Count, "AC").End(xlUp).Row)).Copy Master.Worksheets(2).Range("F" & Rows.Count).End(xlUp).Offset(1, 0) 
End With 
' Sheets(1).Range("D4", Sheets(1).Range("D" & Sheets(1).Cells(Rows.Count, "D").End(xlUp).Row)).Copy Sheets(2).Range("B" & Sheets(2).Rows.Count).End(xlUp).Offset(1, 0) 
ActiveWorkbook.Close (False) 
Next i 
End If 

Set ws = ThisWorkbook.Worksheets("Temp Calc") 

'~~> Start Date and End Date 
N1 = #5/1/2012#: N2 = #7/1/2012# 

With ws 

'~~> Remove any filters 
.AutoFilterMode = False 

'~~> Get the last row 
lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

'~~> Identify your data range 
Set FltrRng = .Range("A1:F" & lRow) 

'~~> Filter the data as per your criteria 
With FltrRng 
'~~> First filter on blanks 
.AutoFilter Field:=6, Criteria1:="=" 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
'~~> Delete the filtered blank rows 
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 

ws.ShowAllData 

'~~> Next filter on Start Date 
.AutoFilter Field:=3, Criteria1:="<" & N1, Operator:=xlAnd 
'~~> Finally filter on End Date 
.AutoFilter Field:=4, Criteria1:=">" & N2, Operator:=xlAnd 

'~~> Filter on col 6 for CNF 
'.AutoFilter Field:=6, Criteria1:="CNF" 

'~~> Delete the filtered rows 
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
End With 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

'~~> Remove any filters 
.AutoFilterMode = False 
End With 

sngTotalTime = Timer - sngStartTime 
MsgBox "Time taken: " & (sngTotalTime \ 60) & " minutes, " & (sngTotalTime Mod 60) & " seconds" 

Application.Goto (ActiveWorkbook.Sheets("Dashboard").Range("A4")) 
Sheets("Dashboard").Select 
Application.ScreenUpdating = True 
End Sub

i read about it but there is no other way ? oh here's a kicker the same code worked under 2 mins yesterday today its been 45 mins and still counting — mathew, Jul 03 '13 at 05:18
for the same set of data? the difference is too big, possibly there is something wrong in your code or data... — Kazimierz Jawor, Jul 03 '13 at 05:20
yeah that is what i am not getting. essentially yes but a few around 5000 employee data were added more — mathew, Jul 03 '13 at 05:23
Add to your loop test which shows which fast is your deleting loop. You could do it like this, by adding right after `For z...`: `Application.Statusbar = z` and you could see working macro progress in status bar in excel application. Set it back to `Application.Statusbar = false` at the end. — Kazimierz Jawor, Jul 03 '13 at 05:32
i was using something like this Dim sngStartTime As Single Dim sngTotalTime As Single sngStartTime = Timer sngTotalTime = Timer - sngStartTime MsgBox "Time taken: " & (sngTotalTime \ 60) & " minutes, " & (sngTotalTime Mod 60) & " seconds" but ill try your way — mathew, Jul 03 '13 at 05:34
oh yea that shows me count.but its seems to be going fast but not fast enough — mathew, Jul 03 '13 at 05:39
[see this](http://stackoverflow.com/questions/17044788/deleting-rows-in-excel-using-vba-depending-on-values-found-using-a-formula/17045742#17045742) and/or [this](http://stackoverflow.com/questions/16901436/efficient-way-to-delete-entire-row-if-cell-doesnt-contain/17047208#17047208) — , Jul 03 '13 at 07:11
as i have mentioned above mehow, i am not familiar with working with arrays can u add comments to it so i know what does what. apologies for the inconvenience — mathew, Jul 03 '13 at 07:59
@mathew: you could use a formula to identify the rows to be deleted, then use `SpecialCells` to select all those rows, then delete them. See [How to delete multiple rows without a loop](http://stackoverflow.com/questions/15431801/how-to-delete-multiple-rows-without-a-loop-in-excel-vba) and [deleting rows takes too long](http://stackoverflow.com/questions/15949174/in-vba-excel-2003-iterating-in-for-loop-for-800-rows-taking-too-much-time-to-get/15950026#15950026) — Our Man in Bananas, Jul 03 '13 at 08:28
impressive solutions philip, but even if i use special formulas to fill a column with suppose na if all the conditions are met/not met. and later delete rows based if this row has na in the particular cell. Wont it still take the same time to delete the rows as before ? as of now i have more than 1,60,000 rows and it will keep growing on a weekly basis. — mathew, Jul 03 '13 at 08:53
As a side note the array efficiency can be improved. The `AND` part of the array should be broken into 3 IF tests - no point testing #2 and #3 if #1 is `FALSE`. So put the most frequent `FALSE` test as the first `IF` etc — brettdj, Jul 03 '13 at 09:16
ohk i am warming up to the filter idea as i read more about it, just a weird question. Can i code a filter in such a way that it everytime the macro is executed a pop up box comes and asks for the the terms to be filtered out, and multiple terms can be applied for multiple columns. i dont think its possible but just to satisfy my curiosity in case it can be done. — mathew, Jul 03 '13 at 10:18
with more than a MILLION rows it will take a long time and use a lot of memory no matter what you do... — Our Man in Bananas, Jul 03 '13 at 15:26
i have not given up hope philip :). I will do it. one way or another i will do it. — mathew, Jul 04 '13 at 02:48

score 0 · Accepted Answer · answered Jul 12 '13 at 06:02

this works for me ..... thank you everyone.... it is achieved using an advanced filter

Dim x, rng As Range
    x = Array("BENIN-00001", "BENIN-00002", "BENTB-0001", "BENTB-0002", "BENTB-0003", "BENTB-0004", _
    "BENTB-0005", "BENTB-0006", "BENTB-0007", "BENTB-0008", "BENTH-00001", "CRPTB-00002", "GDSGL-00001", _
    "GDSIN-00001", "GDSIN-00002", "GDSIN-00003", "LSIED-00001", "LSIES-00001", "PRSGS-00001", "PRSGS-00002", _
    "PRSGS-00003", "PRSGS-00006", "PRSGS-00007", "PRSGS-00008", "PRSPS-00001", "PRSPS-00002", "PRSTB-0001", _
    "PRSTB-0002", "PRSTB-0003", "PRSTB-0004", "PRSTB-0005", "PRSTB-0006", "PRSTB-0007", "SNMIN-00001", "SNMIN-00002", _
    "TRGIN-00001", "TRGIN-00002", "TRGTH-00001", "BENEU-00002", "BENEU-00003", "GDSEU-00002", "GDSEU-00003", _
    "GDSEU-00004", "PRSGS-00005", "PRSGS-00061", "PRSPS-00004", "PRSPS-00005", "TRGEU-00002", "TRGGB-00001", _
    "BENMX-00001", "BENUS-00001", "BENUS-00002", "GDSCA-00001", "GDSGL-00002", "GDSMX-00001", "GDSUS-00001", _
    "GDSUS-00002", "LSIPP-00001", "PRSGS-00004", "PRSPS-00003", "TRGMX-00001", "TRGUS-00001")
    With Sheets("Temp Calc").Cells(1).CurrentRegion
        On Error Resume Next
        .Columns(6).SpecialCells(4).EntireRow.Delete
        On Error GoTo 0
        Set rng = .Offset(, .Columns.Count + 1).Cells(1)
        .Cells(1, 5).Copy rng
        rng.Offset(1).Resize(UBound(x) + 1).Value = Application.Transpose(x)
        .AdvancedFilter 1, rng.CurrentRegion
        .Offset(1).EntireRow.Delete
        On Error Resume Next
        .Parent.ShowAllData
        On Error GoTo 0
        rng.EntireColumn.Clear
    End With

faster deletion of rows

1 Answers1