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()
'
'JB
'
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!