'copy in new workbook
Range("A2", Range("F500").End(xlDown)).Copy
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2").Select
Columns("C:D").Select
Selection.EntireColumn.Delete
Dim UsdRws As Long, k As Long
Application.ScreenUpdating = False
UsdRws = Range("A" & Rows.Count).End(xlUp).Row
For k = UsdRws To 2 Step -1
'If Cells(k, 1).Interior.Color = 65535 Then
'Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
'Rows(k).Delete
'End If
'Next k
If Range("A" & k).Value Like "Exclusions" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusions" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusions *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusions *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusion" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusion" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusion *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusion *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusion * " Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusion-*" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Excl" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Excl *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl-* " Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl-*" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
End If
Next k
Application.ScreenUpdating = True
Range("A1:D1").Copy
Range("G1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
ActiveSheet.UsedRange.Select
Selection.Copy
Sheets("sheet1").Select
Range("G2").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
ActiveSheet.UsedRange.Clear
Cells(1, 1).Select
Sheets("Sheet1").Select
ActiveWindow.Zoom = 90
Columns("E:F").Select
Selection.ColumnWidth = 4