Splitting workbooks

[sanders]

Hi,
I am using the code below to separate out the individual workheets an
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
separate folder (if each sheet is named after a department, fo
example, can that sheet be put in that department's folder)?
Also, can the sheets, once added to the correct folder, then be adde
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 25
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 Su

 

[Bob Phillips]

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)