ExcelBanter - Splitting workbooks

Not tested

Sub Copy_All_Sheets_To_New_Workbook()
Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim YearDateString As String
Dim FolderName As String

Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
YearDateString = Format(Now, "yy")
Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & _
Left(WbMain.Name, Len(WbMain.Name) - 4) & " " & DateString
MkDir FolderName

For Each sh In WbMain.Worksheets

If sh.Visible = -1 Then

sh.Copy

'Line below stops truncation where cell 255 characters.'
ActiveSheet.Range("A1:AZ1000").Value = _
sh.Range("A1:AZ1000").Value
Set Wb = ActiveWorkbook

'Converts formulas to values.
With Wb.Sheets(1)
UsedRange.Copy
UsedRange.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
End With

FolderName = WbMain.Path & "\" & _
Wb.Sheets(1).Name & "\" & _
Left(WbMain.Name, Len(WbMain.Name) - 4) & " " & DateString
MkDir FolderName

Wb.SaveAs FolderName & "\" & _
"Renewq" & YearDateString & Wb.Sheets(1).Name & ".xls"
Wb.Close True

End If

Next sh

MsgBox "Look in " & FolderName & " for the files"

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"sanders" wrote in
message ...

Hi,
I am using the code below to separate out the individual workheets and
put them into separate sheets.
At present they go into a folder with the name 'Workbook - date -
time'
Is it possible to modify the code so that each sheet goes into a
separate folder (if each sheet is named after a department, for
example, can that sheet be put in that department's folder)?
Also, can the sheets, once added to the correct folder, then be added
to separate workbooks?

Thanks,

'
Sub Copy_All_Sheets_To_New_Workbook()

Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim YearDateString As String
Dim FolderName As String

Application.ScreenUpdating = False
Application.EnableEvents = False

DateString = Format(Now, "yy-mm-dd hh-mm-ss")
YearDateString = Format(Now, "yy")
Set WbMain = ThisWorkbook

FolderName = WbMain.Path & "\" & Left(WbMain.Name, Len(WbMain.Name) -
4) & " " & DateString
MkDir FolderName

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy

'The line below stops truncation where cell length is greater than 255
characters.'
ActiveSheet.Range("A1:AZ1000").Value = sh.Range("A1:AZ1000").Value
Set Wb = ActiveWorkbook

'Converts formulas to values.
With Wb.Sheets(1)
UsedRange.Copy
UsedRange.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
End With

Wb.SaveAs FolderName _
& "\" & "Renewq" & YearDateString & Wb.Sheets(1).Name & ".xls"
Wb.Close True
End If
Next sh

MsgBox "Look in " & FolderName & " for the files"

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

--
sanders
------------------------------------------------------------------------
sanders's Profile:
http://www.excelforum.com/member.php...o&userid=36745
View this thread: http://www.excelforum.com/showthread...hreadid=565066