Agfdhyk

To make the situation easily understandable I am taking example.

I have a excel files with following worksheets in it.
City1
City2
City3
City4
City5 and so on till 47 sheets

The file destination is "C:UsersDellDesktopCityData"

I want a VB code which could 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 that code create the folders automatically) (The folders should be created as subfolders of the above destination folder)

 Sub SplitSheets()

 Const FolName = "C:UsersDellDesktopCityData"

 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

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