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!

[IRish3538]

After you add the new worksheet, pop this in there:

' assuming you want it to save in the same folder
 fldr = ThisWorkbook.Path
ThisWorkbook.Sheets("UniqueList").Select
         ThisWorkbook.Sheets("UniqueList").Copy
ActiveWorkbook.SaveAs (fldr & "\UniqueList")
         Workbooks("UniqueList.xlsx").Close

[freybe06]

Thanks Irish!

Is there any way you could paste that code in to mine so I know exactly where I should put it? Sorry for being a pain - I just want to make sure I'm getting this right.

Thanks again!

[IRish3538]

no problem... i gues i would throw it at the very end right before you turn back on screenupdating and displayalerts.

[freybe06]

Irish - Actually, looking at this code again. I'm not sure it will do what I need. I need a new workbook for every new worksheet that opens. So if the "unique list" has 6 different items, it will open 6 different workbooks and save each one with it's own path.

Maybe I'm just missing something but is that what this code will do?

Thanks!

[IRish3538]

I don't see anywhere in your code where you're creating more than one sheet... if there was, you would throw it inside the for next loop that creates the sheet. did you write the original code?

[IRish3538]

nevermind... i found it. at the end you have:

   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

we want to throw the code somewhere in there before the "next rCell"

' Set the path somewhere before it all
fldr = ThisWorkbook.Path 
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 
        '--Add it here--
        ThisWorkbook.Sheets(ManagerList).Select 
        ThisWorkbook.Sheets(ManagerList).Copy 
        ' I'm not sure if "ManagerList will be mutually exclusve, so I added 'rcell' into the workbook name so each one is unique
        ActiveWorkbook.SaveAs (fldr & "\ManagerList & " - " & rCell) 
        Workbooks(ManagerList & " - " & rCell & ".xlsx").Close 
        '-------------------
    Next rCell 
    End With

[freybe06]

Irish - I know its been a while since you had last responded but I was hoping maybe you could help. I have the same issue with this macro but I need to change how it works a little bit. I've made some changes to the macro and worked around some areas so I'd like to be able to put something at the end without messing with any of the other code.

Is there a way to add at the end of the macro some code that essentially says "start with the 2nd worksheet and open a new workbook for each worksheet until the 2nd to last worksheet"?

Thanks again! I appreciate you taking the time to help out with this!

[Aussiebear]

Try this;

Sub CreateWorkbooksFromSheets()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim filePath As String
    ' Loop through each worksheet in the active workbook
    For Each ws In ThisWorkbook.Worksheets
        ' Create a new workbook
        Set newWb = Workbooks.Add
        ' Copy the current worksheet to the new workbook
        ws.Copy Before:=newWb.Sheets(1)
        ' Delete the default empty sheets in the new workbook (if any exist)
        Application.DisplayAlerts = False 
        ' Suppress prompts
        Dim i As Long
        For i = newWb.Sheets.Count To 2 Step -1 
            ' start at the end and work backwards
            newWb.Sheets(i).Delete
        Next i
        Application.DisplayAlerts = True 
        ' Restore prompts
        ' Construct a file path and name (you can customize this)
        filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
        ' Save the new workbook    newWb.SaveAs Filename:=filePath, FileFormat:=xlOpenXMLWorkbook
        ' Close the new workbook
        newWb.Close
    Next ws
    MsgBox "Workbooks created for each worksheet.", vbInformation
End Sub