[SLEEPER:] New Workbook for each worksheet

New Workbook for each worksheet

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:

Code:

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!

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

Code:

' 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

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!

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

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!

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?

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

Code:

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"

Code:

' 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

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!

Try this;

Code:

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