Dave, here it is as it now stands, I've definitely not put something
in correctly on the 'save' routine
Option Explicit
Sub ExtractAMs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Long
Dim c As Range
Dim LastRow As Long
Dim myFileName As String
Application.ScreenUpdating = False
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
.Columns("A:Q").Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
wsNew.Parent.Activate
wsNew.Select
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False
wsNew.Select
Range("A1").Select
With wsNew
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A12:Q" & LastRow).Subtotal _
GroupBy:=2, Function:=xlSum, TotalList:=Array(10), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With
myFileName = c.Parent.Parent.FullName 'includes path, too
'remove the .xls
myFileName = Left(myFileName, Len(myFileName) - 4)
'add the worksheet name and .xls
myFileName = myFileName & " - " & c.Value & ".xls"
'stop the "overwrite?" prompt
Application.DisplayAlerts = False
.Parent.SaveAs Filename:=myFileName,
FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
'close it
.Parent.Close savechanges:=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 - 2
.Range("R13:R" & LastRow).Formula _
= "=VLOOKUP(B13,AM_Lookup,2,false)"
End With
End Sub