VBA code to filter and copy data to new workbook

I created below code to delete unwanted data and copy to new workbook but it took long time. 4000 plus records take me around 30 minutes. I try to create code for filter and copy few sheets to new workbook but failed. Anyone could help to solve my problem?

Sub RejectionList()

Dim DataWorkbook
Dim SaveFileName As String
Dim ws As Worksheet

Set DataWorkbook = ActiveWorkbook
DataWorkbook.Sheets(Array("IT7", "IT2003", "IT2002", "IT2006", "IT2001", "IT2005", "IT2007")).Copy
Last = Sheets("IT7").Cells(Rows.Count, "H").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT7").Cells(i, "H").Value) = "Reject" Then
Sheets("IT7").Cells(i, "H").EntireRow.Delete
End If
Next i

Last = Sheets("IT2003").Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2003").Cells(i, "K").Value) = "Reject" Then
Sheets("IT2003").Cells(i, "K").EntireRow.Delete
End If
Next i

Last = Sheets("IT2002").Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2002").Cells(i, "K").Value) = "Reject" Then
Sheets("IT2002").Cells(i, "K").EntireRow.Delete
End If
Next i

Last = Sheets("IT2006").Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2006").Cells(i, "K").Value) = "Reject" Then
Sheets("IT2006").Cells(i, "K").EntireRow.Delete
End If
Next i

Last = Sheets("IT2001").Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2001").Cells(i, "K").Value) = "Reject" Then
Sheets("IT2001").Cells(i, "K").EntireRow.Delete
End If
Next i

Last = Sheets("IT2005").Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2005").Cells(i, "K").Value) = "Reject" Then
Sheets("IT2005").Cells(i, "K").EntireRow.Delete
End If
Next i

Last = Sheets("IT2007").Cells(Rows.Count, "J").End(xlUp).Row
For i = Last To 2 Step -1
If (Sheets("IT2007").Cells(i, "J").Value) = "Reject" Then
Sheets("IT2007").Cells(i, "J").EntireRow.Delete
End If
Next i

Sheets("IT7").Columns("I:Z").Delete
Sheets("IT2003").Columns("L:Z").Delete
Sheets("IT2002").Columns("L:Z").Delete
Sheets("IT2006").Columns("L:Z").Delete
Sheets("IT2001").Columns("L:Z").Delete
Sheets("IT2005").Columns("L:Z").Delete
Sheets("IT2007").Columns("L:Z").Delete
Application.DisplayAlerts = False

Application.DisplayAlerts = True
SaveFileName = DataWorkbook.Path & "\" & Left(DataWorkbook.Name, Len(DataWorkbook.Name) - 8) & ".xlsx"
ActiveWorkbook.SaveAs Filename:=SaveFileName
MsgBox "Rejection List To TA Created and Save As" & SaveFileName
ActiveWorkbook.Close


End Sub

when you filter data in a sheet you can just copy the filtered sheet in any other locations

a sample trivial data in sheet1 is attached. download the file. the macros are already in module in vb editor "test" and "undo"
run the macro "test". it will copy filtered data in sheet 2

Please Login or Register  to view this content.

Please Login or Register  to view this content.