Separate Worksheets into Workbooks

Submitted by Tommy Miles.

This sample goes through the active workbook and saves each sheet as its own workbook in the same path as the original workbook. It names the new workbooks based upon the sheet name. It does not overwrite files without prompting:

Sub SplitWorkbook()

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 = "Sheetl" ActiveWorkbook.SaveAs Filename:=NewFileName

ActiveWorkbook.Close SaveChanges:=False

Else

NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xls"

ws.Name = "Sheetl"

ThisWorkbook.SaveAs Filename:=NewFileName End If

Next

Application.StatusBar = False Application.DisplayStatusBar = DisplayStatusBar Application.ScreenUpdating = True End Sub

0 0

Post a comment