It was supposed to be a peaceful Friday night in office. As I was about to leave the office on time, I was bombed with a very stupid task. Actually, We had some 8-10 files related to some important data and each Excel file contained 10-15 sheets. The task was to extract all those sheets into individual excel file. For me, to do this manually was like digging the well with spoon. It would have taken hours to complete the task. So I thought of trying hands on VBA. It was pretty easy and quick to do this with VBA and within half hour, I was done with my code and task to Extract sheet to files. (Note that I have written the code from scratch. I found below mentioned code segments on some sites and adjusted it to meet my goal.) Lets see how we did that.
First, I tried to extract the excel sheets for the single Excel file.(Please note that i have written this code. Copied it from this location)
Sub Splitbook()
Dim xPath As String
'Pick current excel path
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Loop through all sheets
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
'Save excel file with sheet name
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Well, that works pretty straight. It extracted all the sheets into files(naming sheet name as file name) Now, the next challenge was to loop through all the files in a folder, process each file and loop through its sheets. For that, I created a new Macro-supported file (.xlsm) file. Pressed [Alt] + [F11]. This opens up the code window. In that, go to Menu -> Insert -> Module and pasted these lines -
Sub SplitAllBook()
Dim fso As Object
Dim xPath As String
Dim wbk As Workbook
Dim Filename As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xPath = "YOUR_SOURCE_FOLDER_NAME_HERE"
'Pick only ".xlsx" files. In case you want to process older version of files, please change the extension to .xls
Filename = Dir(xPath & "*.xlsx")
'Loop through all files
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Filename:=xPath & Filename)
'Use fso to remove the extension from file name. We used this name to Name excel file.
Set fso = CreateObject("scripting.filesystemobject")
Dim tempFileName As String
tempFileName = fso.GetBaseName(Filename)
'Loop through all sheets
For Each xWs In wbk.Sheets
xWs.Copy
'I have used naming convention as - OriginalFileName_SheetName.xlsx to avoid name conflict. You can put any logic you want.
Application.ActiveWorkbook.SaveAs Filename:="YOUR_DESTINATION_FOLDER_NAME_HERE\" & tempFileName & "_" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
wbk.Close True
Filename = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
With that, we are done. Run you macro and you should get all the sheets created as new excel files in the destination folder.Tip -
I faced a couple of problems while running the code.
1. Unique Name for files - Figure out a way to provide a unique name to your file or else the macro will throw the error.
2. Folder Path - Define your folder path correctly with all the "\" etc wherever required. In case a problem occurs, a quick debug will solve it easily.
Sample Code
Thank you.
But these files didn't open as expected. The Image viewer displayed it as the crashed image and the PDF were displayed as corrupted as well. I was on Zero again. 
