Programatically Creating Worksheets

This code is useful for breaking single spreadsheets out into multiple worksheets based on a cell value.  This code, used in conjunction with the following code can automate breaking out worksheets for files that need to be cascaded out to managers, for example.


Sub NewWorksheetForEachDept()
Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range

Set WBO = ThisWorkbook
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("P" & Rows.Count).End(xlUp))

With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

ActiveSheet.ShowAllData

End With

For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
'counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
'rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
Next cell
rngFilter.Parent.AutoFilterMode = False
End Sub

This code, found below is a way to automate saving the worksheets you just broke out into separate tabs into new workbooks


Sub CreateNewWBS()
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Set wbThis = ThisWorkbook
For Each ws In wbThis.Worksheets
strFilename = wbThis.Path & "/" & ws.Name
ws.Copy
Set wbNew = ActiveWorkbook
wbNew.SaveAs strFilename
wbNew.Close
Next ws
End Sub

Sources:

http://www.mrexcel.com/forum/excel-questions/486738-copying-saving-worksheets-large-workbook-into-separate-files.html

http://www.mrexcel.com/forum/excel-questions/694644-excel-visual-basic-applications-create-worksheets-based-unique-values-list-copy-data-applicable-worksheet.html