New Workbook for each worksheet

[freybe06]

Hello Everyone,

I'm having a little trouble adding some code to my current macro. What I'd like to do is for every new worksheet that is created via the macro, I want to copy that to it's own workbook. Right now the worksheets are just added to the current workbook. When I have tried to add the code in there, it usually throws more than one worksheet in each new workbook.

Here is the code I currently have:

 
Sub AutomationMacro()
    Application.ScreenUpdating = False
    Sheets("Extended Holdings Report").Select
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Formula = "Manager"
    Range("B2").FormulaR1C1 = "=INDEX('Manager Info'!C[0],MATCH('Extended Holdings Report'!C[-1],'Manager Info'!C[-1],0))"
    Range("B2").AutoFill Destination:=Range("B2:B" & LastRow), Type:=xlFillCopy
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Columns("R:R").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("R1").Formula = "Book Price"
    Range("R2").FormulaR1C1 = "=('Extended Holdings Report'!C[-3]/'Extended Holdings Report'!C[-8])*100"
    Range("R2").AutoFill Destination:=Range("R2:R" & LastRow), Type:=xlFillCopy
    Columns("R:R").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("DI:DM").Delete
    Range("AT:DF").Delete
    Range("AQ:AR").Delete
    Range("AL:AO").Delete
    Range("AF:AH").Delete
    Range("Z:AC").Delete
    Range("S:X").Delete
    Range("P:P").Delete
    Range("K:N").Delete
    Range("H:H").Delete
    Range("F:F").Delete
    Range("C:D").Delete
    Range("A:A").Delete
    Sheets("Extended Holdings Report").Activate
    Sheets("Extended Holdings Report").Cells.Select
    With Selection.Font
        .Name = "Trebuchet MS"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
       .PatternTintAndShade = 0
    End With
    Range("A1").Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    Dim rRange As Range, rCell As Range
    Dim wSheet As Worksheet
    Dim wSheetStart As Worksheet
    Dim ManagerList As String
    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    ' Set a range variable to the correct item column
    Set rRange = Range("A1", Range("A20000").End(xlUp))
    ' Delete any sheet called "UniqueList"
    ' Turn off run time errors & delete alert
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("UniqueList").Delete
    ' Add a sheet called "UniqueList"
    Worksheets.Add().Name = "UniqueList"
    ' Filter the Set range so only a unique list is created
    With Worksheets("UniqueList")
        rRange.AdvancedFilter xlFilterCopy, , _
        Worksheets("UniqueList").Range("A1"), True
        ' Set a range variable to the unique list, less the heading.
        Set rRange = .Range("A1", Range("A20000").End(xlUp))
    End With
    On Error Resume Next
    With wSheetStart
        For Each rCell In rRange
            ManagerList = rCell
            .Range("A1").AutoFilter 1, ManagerList
            Worksheets(ManagerList).Delete
            ' Add sheet named as content of rCell
            Worksheets.Add().Name = ManagerList
           ' Copy the visible filtered range and leave hidden rows
           .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Cells.Columns.AutoFit
        Next rCell
    End With
    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With
    On Error GoTo 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Thanks in advance!