VBA to create seperate workbooks for every sheet of the active workbook

Hello,

i have workbook with numerous worksheets, i need help with a macro that can create separate workbook for every sheet in the Thisworkbook and to save them exactly in the same directory and also file format should be the same as the original file.

thanks alot
LVL 6
FloraAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongCommented:
try customize this..

Sub copyActiveWB()
    Dim wb As Workbook
    Dim fExt As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = Application.Workbooks.Add
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy After:=wb.Sheets(wb.Sheets.Count)
    Next
    wb.Sheets(3).Delete
    wb.Sheets(2).Delete
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    fExt = getFileExt(ThisWorkbook.Name)
    wb.SaveAs ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, fExt, "") & "_" & Format(Now(), "DDMMYYYY HHMMSS") & fExt, ThisWorkbook.FileFormat
End Sub

Function getFileExt(f As String) As String
    Dim pos As Integer
    pos = InStrRev(f, ".", , vbTextCompare)
    If pos > 0 Then
        getFileExt = Mid(f, pos)
    Else
        getFileExt = ""
    End If
End Function

Open in new window


>>and to save them exactly in the same directory and also file format should be the same as the original file.
you need to specify the file name you want...
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You may try something like this....

Sub SaveEachSheetToANewWorbook()
Dim Swb As Workbook, Dwb As Workbook
Dim Sws As Worksheet
Dim MyFile As String, MyFilePath As String, MyFileExt As String, sFileName As String

Application.ScreenUpdating = False
MyFile = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")


If MyFile = "False" Then
    MsgBox "No file selected.", vbExclamation, "Sorry!"
    Exit Sub
Else
    Workbooks.Open Filename:=MyFile
End If

Set Swb = ActiveWorkbook
MyFilePath = Swb.Path
MyFileExt = Swb.Name
sFileName = Swb.Name
MyFileExt = WorksheetFunction.Replace(MyFileExt, 1, InStr(MyFileExt, "."), "")
DoEvents
Application.DisplayAlerts = False
For Each Sws In Swb.Worksheets
    Sws.Copy
    ActiveWorkbook.SaveAs MyFilePath & "\" & Sws.Name & "." & MyFileExt, Swb.FileFormat
    ActiveWorkbook.Close
Next Sws
Application.DisplayAlerts = True
Swb.Close
Application.ScreenUpdating = True
MsgBox "All sheets of " & sFileName & " Have been saves as New workbooks at the location " & MyFilePath & ".", vbInformation, "Done!"
End Sub

Open in new window

For detail refer to the attached workbook and click on the button on Sheet1 to run the code.
The code will open a File Open dialog box for you to choose the Source Workbook and then it will save all the sheets of the opened workbook as New Workbooks at the same location where the opened file is located.
CopyEachSheetToANewWorkbook.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
your second post, did it.

thanks.  your first code did not work.
0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please ignore the typo in the msgbox line of the suggested code. It should be Saved not saves.
Please correct it in the code.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Which second post? I posted only one code. Probably you misread something. :)
0
FloraAuthor Commented:
you have posted ID: 40988485  which did not work.

then you have posted ID: 40988664  that worked, but still not exactly as i wanted it.

becuase i have to click and open a workbook to be split.  cannot this be modified so that it splits "THISWORKBOOK" from which the code is run. instead of openning diologbox and selecting the workbook,
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I think you seem to be in hurry.
Post 40988485 was posted by Ryan and post 40988664 is posted by sktneer. :)

Anyways yes the code can be modified to do what you are asking.
I will post the modified code back.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay here is the modified code. Place this code on Standard Module of your source workbook.
Sub SaveEachSheetToANewWorbook()
Dim Swb As Workbook, Dwb As Workbook
Dim Sws As Worksheet
Dim MyFilePath As String, MyFileExt As String, sFileName As String

Application.ScreenUpdating = False

Set Swb = ThisWorkbook
MyFilePath = Swb.Path
MyFileExt = Swb.Name
sFileName = Swb.Name
MyFileExt = WorksheetFunction.Replace(MyFileExt, 1, InStr(MyFileExt, "."), "")
DoEvents
Application.DisplayAlerts = False
For Each Sws In Swb.Worksheets
    Sws.Copy
    ActiveWorkbook.SaveAs MyFilePath & "\" & Sws.Name & "." & MyFileExt, Swb.FileFormat
    ActiveWorkbook.Close
Next Sws
Application.DisplayAlerts = True

Application.ScreenUpdating = True
MsgBox "All sheets of " & sFileName & " Have been saved as New workbooks at the location " & MyFilePath & ".", vbInformation, "Done!"
End Sub

Open in new window

0
FloraAuthor Commented:
sktneer

thanks very much.  i overlooked the names.  that was your first code that worked.

 yes, it was Ryan's code which did not work.

:-)
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay no issues.
Did the modified code work as per your expectations?
0
FloraAuthor Commented:
it worked but one problem, the created file names only show sheetnames and there is no reference of the workbookname.

what i wanted was that lets say my  source workbook name is "REPORT" then all created files should have "WORKBOOKNAME_SHEETNAME_DATE"  like this  REPORT_SHEET1_22092015
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay try this....
Sub SaveEachSheetToANewWorbook()
Dim Swb As Workbook, Dwb As Workbook
Dim Sws As Worksheet
Dim MyFile As String, MyFilePath As String, MyFileExt As String, sFileName As String

Application.ScreenUpdating = False

Set Swb = ThisWorkbook
MyFilePath = Swb.Path
MyFileExt = Swb.Name
sFileName = Swb.Name
MyFile = WorksheetFunction.Replace(sFileName, InStr(sFileName, "."), 5, "")

MyFileExt = WorksheetFunction.Replace(MyFileExt, 1, InStr(MyFileExt, "."), "")
DoEvents
Application.DisplayAlerts = False
For Each Sws In Swb.Worksheets
    Sws.Copy
    ActiveWorkbook.SaveAs MyFilePath & "\" & MyFile & "_" & Sws.Name & "_" & Format(Date, "ddmmyyyy") & "." & MyFileExt, Swb.FileFormat
    ActiveWorkbook.Close
Next Sws
Application.DisplayAlerts = True

Application.ScreenUpdating = True
MsgBox "All sheets of " & sFileName & " Have been saved as New workbooks at the location " & MyFilePath & ".", vbInformation, "Done!"
End Sub

Open in new window

0
FloraAuthor Commented:
sktneer

you are a legend. worked perfectly

thanks a million
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Flora. Glad I could help. :)
1
Ryan ChongCommented:
>>your first code did not work.
as mentioned, you may need to customize the suggested scripts, sometimes we can't predict 100% what the asker want. The scripts is always tested before it was posted. anyway good that you found the solution.
0
FloraAuthor Commented:
Ryan Chong

i thank you sincerely for your willingness to help. it is appreciated.

as i am a newbiew vba learner, i could not figure out how to modify your code and put it to use.

luckly sktneer has chipped in and helped me.

but i also thank you for your help.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.