Save each sheet of multi-sheet workbook as a single-sheet workbook

  • Thread starter Thread starter CTB
  • Start date Start date
C

CTB

MS Office Excel 2007

Hello all,

I have 5 huge workbooks each with 12 sheets of monthly data (sheet
names are in the format of "mmm yyyy"). I'm trying to split them up
into 12 not-as-huge single-sheet workbooks.

When I use "Worksheet.SaveAs" (see code pasted at the end), all 12
sheets are saved in the new workbook with the desired name...not just
the desired sheet.

How do I create 12 single-sheet workbooks from 1 12-sheet workbook?
Do I need to copy/move sheet to new workbook and save new workbook
with desired name?

Thanks for any help anyone can provide,

CTB





******** Code: ********

Option Explicit

Sub SplitSheets()
Dim pfso As New FileSystemObject
Dim pfsoSourceFolder As Folder
Dim pfsoDestFolder As Folder
Dim pstrDestFolder As String
Dim pfsoFile As File

Dim pwkbSource As Workbook
Dim pwksSource As Worksheet

Dim pstrDate As String
Dim pdteDate As Date

Dim pstrDestFileName As String


pstrDestFolder = "New Folder"
Set pfsoFile = pfso.GetFile(Application.GetOpenFilename)
Set pfsoSourceFolder = pfsoFile.ParentFolder
Set pfsoDestFolder = pfso.GetFolder(pfsoSourceFolder.Path &
Application.PathSeparator & pstrDestFolder)

For Each pfsoFile In pfsoSourceFolder.Files
Set pwkbSource = Application.Workbooks.Open(pfsoFile.Path, ,
True)

For Each pwksSource In pwkbSource.Worksheets
'pwksSource.Activate
pstrDate = pwksSource.Name
pdteDate = DateValue(pstrDate)
pdteDate = DateSerial(Year(pdteDate), Month(pdteDate) + 1,
0)
pstrDate = Format(pdteDate, "yyyy-mm-dd")

pstrDestFileName = pfsoDestFolder.Path &
Application.PathSeparator & pstrDate
'pstrDestFileName = pfsoDestFolder.Path &
Application.PathSeparator & pstrDate & ".xlsx"

pwksSource.SaveAs pstrDestFileName, xlOpenXMLWorkbook

Next pwksSource

pwkbSource.Close False
Next pfsoFile
End Sub
 
Try...

Sub SplitSheets2()
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
'Copy to new workbook making it now the active workbook
wks.Copy
With ActiveWorkbook
.SaveAs ActiveWorkbook.Path & wks.Name & ".xls"
.Close
End With
Next
ActiveWorkbook.Close '//next workbook
End Sub
 
GS formulated on Monday :
.SaveAs ActiveWorkbook.Path & wks.Name & ".xls"
Click to expand...

Oops: forgot path separator. Change above to...

.SaveAs ActiveWorkbook.Path & "\" & wks.Name & ".xls"
 
GS formulated on Monday :
Try...

Sub SplitSheets2()
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
'Copy to new workbook making it now the active workbook
wks.Copy
With ActiveWorkbook
.SaveAs ActiveWorkbook.Path & wks.Name & ".xls"
.Close
End With
Next
ActiveWorkbook.Close '//next workbook
End Sub
Click to expand...

Well, this needs to be revised to save the new workbooks to the source
workbook path, since the new (ActiveWorkbook above) doesn't have a path
yet because it's never been saved. Change as follows...


Sub SplitSheets2()
Dim wks As Worksheet, sFullPath As String
sFullPath = ActiveWorkbook.Path & "\"
For Each wks In ActiveWorkbook.Worksheets
'Copy to new workbook making it now the active workbook
wks.Copy
With ActiveWorkbook
.SaveAs FullPath & wks.Name & ".xls"
.Close
End With
Next
ActiveWorkbook.Close '//next workbook
End Sub
 
Back
Top