Sub SplitWorkbook()
' Solution by Tommy Miles
' Saves each worksheet as separate workbook
' in the same directory as original.
Dim ws As Worksheet
Dim DisplayStatusBar As Boolean
DisplayStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets
Dim NewFileName As String
Application.StatusBar = ThisWorkbook.Sheets.Count & " Remaining Sheets"
If ThisWorkbook.Sheets.Count <> 1 Then
NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xls"
ws.Copy
ActiveWorkbook.Sheets(1).Name = "Sheet1"
ActiveWorkbook.SaveAs Filename:=NewFileName
ActiveWorkbook.Close SaveChanges:=False
Else
NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xls"
ws.Name = "Sheet1"
ThisWorkbook.SaveAs Filename:=NewFileName
End If
Next
Application.StatusBar = False
Application.DisplayStatusBar = DisplayStatusBar
Application.ScreenUpdating = True
End Sub