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