freybe06
02-19-2013, 02:12 PM
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!
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!