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
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