Copy Page Setup Options when splitting into multiple workbooks

BankerZ

New Member
Joined
Jul 7, 2008
Messages
2
I have found success splitting one large worksheet into multiple workbooks based on common values in Column A of my spreadsheet with the macro below (thanks to Andrew Poulsom's solution in this thread: http://www.mrexcel.com/forum/showthread.php?t=319499.

I have two additional needs:

1 - To copy the Page Setup Options from the original worksheet to the new workbooks created.

2 - Password protect each of the new workbooks created.

What additions do I need to make to the following to make that possible.

Any assistance is greatly appreciated.

Sub Test()
Const xlColumnWidths = 8
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim WB As Workbook
Application.ScreenUpdating = False
'' *** Change Sheet name to suit ***
Set Sh = Worksheets("All")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:AA" & Sh.Range("A65536").End(xlUp).Row)
For Each Item In List
Set WB = Workbooks.Add
Sh.Cells.Copy
WB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Rng.AutoFilter Field:=1, Criteria1:=Item
Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
Rng.AutoFilter
With WB
.SaveAs ThisWorkbook.Path & "\ProjectName - " & Item & ".xls"
.Close
End With
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
An additional option that will work for me is creating a unique worksheet within the original workbook (rather than creating a new workbook for each). Then I can simply highlight all worksheets and create the page options needed.

Any help with that thought would also be appreciated.
 
Upvote 0

Forum statistics

Threads
1,215,054
Messages
6,122,897
Members
449,097
Latest member
dbomb1414

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top