Option Explicit
Sub CreateSheets()
Dim Cell As Range
Dim RngBeg As Range
Dim RngEnd As Range
Dim Wks As Worksheet
Set RngBeg = Worksheets("Master").Range("A2")
Set RngEnd = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp)
' Exit if the list is empty.
If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
For Each Cell In Worksheets("Master").Range(RngBeg, RngEnd)
On Error Resume Next
' No error means the worksheet exists.
Set Wks = Worksheets(Cell.Value)
' Add a new worksheet and name it.
If Err <> 0 Then
Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Wks.Name = Cell.Value
End If
On Error GoTo 0
Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub
Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Master"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
If Sheets(dst).Name <> srcSheet Then
Sheets(srcSheet).Rows("1:1").Copy
Sheets(dst).Activate
Sheets(dst).Range("A1").PasteSpecial xlPasteValues
'ActiveSheet.PasteSpecial xlPasteValues
Sheets(dst).Range("A1").Select
End If
Next
Application.ScreenUpdating = True
CopyData
End Sub
Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error GoTo M
Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
For i = 2 To Lastrow
ans = Sheets("Master").Cells(i, 1).Value
Sheets("Master").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
Next
Application.ScreenUpdating = True
Sheets("Master").Activate
Sheets("Master").Range("A1").Select
SplitWorkbook
Exit Sub
M:
MsgBox "No such sheet as " & ans & " exist"
Application.ScreenUpdating = True
End Sub
Sub SplitWorkbook()
Dim FileExtStr, DateString, xFile As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hhmm")
FolderName = xWb.path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub