更快地删除行

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

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

2. 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

Answer 1

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