如果单元格包含某些值，则下面的代码允许我删除行。现在由于某种原因它需要我很多时间（30分钟和计数）。
' 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
使用数组存储整个工作表，然后复制只符合我标准的数据。他非常友好地帮我提出以下代码。但我不熟悉在数组中处理数据。
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
我的问题是，除了上面提到的数据之外，还有更快的方法来删除数组中的行吗？或者排列或过滤我得到的最佳选择。我愿意接受建议。
更新我的新代码如下所示。它不会过滤日期范围，如果它们是硬编码的，任何人都可以告诉我我做错了吗？
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
答案 0 :(得分：0)
这对我有用.....谢谢大家....这是使用高级过滤器实现的
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