Split file into multiple workbooks and save in separate folders - excel

Question

I have excel files with following worksheets.
City1
City2
City3
City4
City5 and so on till 47 sheets
The file destination is "C:\Users\Dell\Desktop\CityData\"
How could I split file into individual sheets and place them in the folders of same names as the name of sheets . The folders do not exist and I want to create the folders automatically. The folders should be created as subfolders of the above destination folder.

Answer 1

Sub SplitSheets()
Const FolName = "C:\Users\Dell\Desktop\CityData\"
Dim ws as worksheet
for each ws in worksheets
ws.copy
Mkdir folname & ws.name
activeworkbook.saveas folname & ws.name & "\" & ws.name & ".xlsm",52
activeworkbook.close
next ws
end sub

Answer 2

You can use this to split a workbook into separate sheets.
Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can copy and move files using the code below.
Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "C:\your_from_path\" '<< Change
ToPath = "C:\your_to_path\" '<< Change
'If you want to create a backup of your folder every time you run this macro
'you can create a unique folder with a Date/Time stamp.
'ToPath = "C:\your_to_path\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub
You could certainly make it more dynamic, if you want to sweep multiple files into multiple different folders. I think the best way to do that would be to list the folders in a column, and then loop through that list of items. Something like this would do the trick.
Dim r As Range '-- if you don't declare it as a range type you get a variant type as default
Dim c As Range '-- this is used to store the single cell in the For Each loop
Set r = Range("A1:B10") '-- substitute your range as per your example
For Each c In r '-- you could also use r.cells
MsgBox c.Value '-- pass to your function instead of a call to the Message Box
Next