How about:

Option Explicit
Sub ExtractReps()

Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long

Set ws1 = Sheets("2007")

With ws1
.Range("R:IV").Delete

'rebuild it each time???
Call InsertAMName

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A12:r" & LastRow)

'extract a list of unique managers in column Y
.Range("r12:r" & LastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), _
Unique:=True

r = Cells(.Rows.Count, "Y").End(xlUp).Row

For Each c In Range("Y2:Y" & r).Cells
'workbooks.add(1) creates a new workbook with a single sheet
'workbooks.add(1).worksheets(1) is that sheet
Set wsNew = Workbooks.Add(1).Worksheets(1)
wsNew.Name = c.Value

'build the criteria range in X1:X2
.Range("x1").Value = .Range("y1").Value
.Range("x2").Value = "=" & Chr(34) & "=" & c.Value & Chr(34)

.Rows("1:11").Copy _
Destination:=wsNew.Range("a1")

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False

wsNew.Range("R:iv").Delete
Next c
End With
ws1.Parent.Activate
ws1.Select
ws1.Columns("R:IV").Delete
End Sub

Sub InsertAMName()

Dim LastRow As Long

Application.ScreenUpdating = False

With Worksheets("2007")
'add a header for column R in Row 12
.Range("R12").Value = "Manager"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With

Application.ScreenUpdating = True

End Sub



Sean wrote:

Dave, I've got a little routine (see very bottom of post) which places
the Managers name in ColR, but I'm a little lost as to what I proceed
next with i.e. the filtering and how I can get this to appear on a new
file for each.

My data goes from A12:R.. I also have some text above Row12 which I
would like to have on each Managers file too

I've tried below, but I get a "End if without Block if" not sure why
on the last End if.

I've ignored your comment on #2 for the moment just want to get the
basic's of the filter working

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("2007")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("R:R").Copy _
Destination:=Range("X12")
ws1.Columns("X:X").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("Y12"), Unique:=True
r = Cells(Rows.Count, "Y").End(xlUp).Row

'set up Criteria Area
Range("X1").Value = Range("R1").Value

For Each c In Range("Y12:Y" & r)

'workbooks.add(1) creates a new workbook with a single sheet
'workbooks.add(1).worksheets(1) is that sheet
Set wsNew = Workbooks.Add(1).Worksheets(1)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("2007").Range("X12:X13"), _
CopyToRange:=wsNew.Range("A12"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("X:Y").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

Routine is:

Sub InsertAMName()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With

Sheets("2007").Select

Range("R13").Select
ActiveCell.Formula = "=VLOOKUP(B13,AM_Lookup,2)"

Range("R13").Copy
x = 13
Do Until Cells(x, 1).Value = ""
Cells(x, 18).PasteSpecial xlPasteFormulas
x = x + 1
Loop

With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With

Range("A1").Select

ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True

End Sub

--

Dave Peterson