Extract All sheets inside a folder to individual Excel File

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.