Option Explicit
Sub ExtractJobs()
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim rngList As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("JOB ENTRY")
Set rng = Range("Database")
'extract a list of Jobs
ws1.Columns("C:C").Copy _
Destination:=Range("F1")
ws1.Columns("F:F").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("E1"), Unique:=True
r = Cells(Rows.Count, "E").End(xlUp).Row
'set up Criteria Area
Range("F1").Value = Range("C1").Value
For Each c In Range("E2:E" & r)
'add the Job name to the criteria area
ws1.Range("F2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(CStr(c.Value)).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("JOB ENTRY").Range("F1:F2"), _
CopyToRange:=Sheets(CStr(c.Value)).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("JOB ENTRY").Range("F1:F2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
'delete unused sheets
ActiveWorkbook.Names.Add Name:="MyList", _
RefersToR1C1:="='" & ws1.Name & "'!R1C5:R" & r & "C5"
Set rngList = ActiveWorkbook.Names("MyList").RefersToRange
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "MASTER" And ws.Name <> "EQUIP TYPE BREAKDOWN" And ws.Name
<> ws1.Name And _
Application.WorksheetFunction.CountIf(rngList, ws.Name) = 0 Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
ws1.Select
ws1.Columns("E:F").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
