How to Export Excel Worksheets to Separate Files Using VBA

Option Explicit 

Sub Export_One_Worksheet_To_XLSX() 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim SaveToDirectory As String 
    Dim fName As String 
     
    On Error GoTo ErrorHandler  ' Start error handling 
     
    Set wb = ActiveWorkbook 
     
    ' Get the path of the Active workbook 
    SaveToDirectory = wb.Path &"\" 
    If SaveToDirectory = "\" Then 
        MsgBox "Please save the workbook before running this macro.", vbExclamation 
        Exit Sub 
    End If 
     
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
     
    ' Export first worksheet 
    Set ws = wb.Worksheets(1) 
    ws.Copy 
    fName = SaveToDirectory &ws.Name &".xlsx" 
    With ActiveWorkbook 
        .SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
        .Close SaveChanges:=False 
    End With 
     
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
     
    MsgBox "First worksheet has been exported successfully.", vbInformation 
    Exit Sub 
     
ErrorHandler: 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    MsgBox "An error occurred: " &Err.Description, vbCritical  ' Notify the user of the error 
     
End Sub 

Option Explicit 

Sub Export_All_Worksheets_To_XLSX_v1() 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim SaveToDirectory As String 
    Dim fName As String 
     
    On Error GoTo ErrorHandler  ' Start error handling 
     
    Set wb = ActiveWorkbook 
     
    ' Get the path of the Active workbook 
    SaveToDirectory = wb.Path &"\" 
    If SaveToDirectory = "\" Then 
        MsgBox "Please save the workbook before running this macro.", vbExclamation 
        Exit Sub 
    End If 
     
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
     
    ' Loop through each worksheet 
    For Each ws In ActiveWorkbook.Worksheets 
        ws.Copy 
        fName = SaveToDirectory &ws.Name &".xlsx" 
        With ActiveWorkbook 
            .SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
            .Close SaveChanges:=False 
        End With 
    Next ws 
     
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
     
    MsgBox "All worksheets have been exported successfully.", vbInformation 
    Exit Sub 
     
ErrorHandler: 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    MsgBox "An error occurred: " &Err.Description, vbCritical  ' Notify the user of the error 
     
End Sub 

' Custom function to clean invalid characters from worksheet name for file saving 
Function CleanFileName(strName As String) As String 
    ' Replace invalid characters with underscore 
    Const invalidChars As String = "\/:*?""<>|" 
     
    Dim i As Integer 
    For i = 1 To Len(invalidChars) 
        strName = Replace(strName, Mid(invalidChars, i, 1), "_") 
    Next i 
     
    ' Trim any trailing spaces or dots from the file name 
    Do While Right(strName, 1) = " " Or Right(strName, 1) = "." 
        strName = Left(strName, Len(strName) - 1) 
    Loop 
     
    ' Return the cleaned name 
    CleanFileName = strName 
End Function 

        ' Clean the worksheet name before saving to new file 
        fName = SaveToDirectory &CleanFileName(ws.Name) &".xlsx" 

Option Explicit 

' *** Module Overview *** 
' This module automates the process of exporting all worksheets in the active workbook 
' as .xlsx files, handling both system restrictions and errors efficiently. 
' 
' Key Features: 
' - Invalid characters in worksheet names are automatically cleaned. 
' - Error handling is included to restore Excel settings and notify the user in case of an error. 
' 
' ### Subroutines and Functions ### 
' 
' - Sub Export_Worksheets_To_XLSX: 
'   - Checks if the workbook has been saved before proceeding with the export. 
'   - Disables screen updates and alerts to enhance performance and prevent unnecessary prompts. 
'   - Exports the all worksheets in the active workbook to new .xlsx files. 
'   - Cleans the worksheet names for file saving by replacing invalid characters and ensuring 
'     compliance with Windows file naming rules. 
'   - Error handling ensures that screen updates and alerts are always restored, even if an error occurs. 
'   - Displays a message box to confirm the successful export. 
' 
' - Function CleanFileName: 
'   - Replaces any invalid characters (e.g., \/:*?"<>|) with underscores. 
' 
' *** End of Module Overview *** 

Sub Export_All_Worksheets_To_XLSX_v2() 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim SaveToDirectory As String 
    Dim fName As String 
     
    On Error GoTo ErrorHandler  ' Start error handling 
     
    Set wb = ActiveWorkbook 
     
    ' Get the path of the Active Workbook 
    SaveToDirectory = wb.Path &"\" 
    If SaveToDirectory = "\" Then 
        MsgBox "Please save the workbook before running this macro.", vbExclamation 
        Exit Sub 
    End If 
     
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
     
    ' Loop through each worksheet 
    For Each ws In ActiveWorkbook.Worksheets 
        ws.Copy 
        ' Clean the worksheet name before saving to new file 
        fName = SaveToDirectory &CleanFileName(ws.Name) &".xlsx" 
        With ActiveWorkbook 
            .SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
            .Close SaveChanges:=False 
        End With 
    Next ws 
     
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
     
    MsgBox "First worksheet has been exported successfully.", vbInformation 
    Exit Sub    ' Exit to avoid error handler running if not needed 
     
ErrorHandler: 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    MsgBox "An error occurred: " &Err.Description, vbCritical  ' Notify the user of the error 
     
End Sub 

' Custom function to clean invalid characters from worksheet name for file saving 
Function CleanFileName(strName As String) As String 
    ' Replace invalid characters with underscore 
    Const invalidChars As String = "\/:*?""<>|" 
     
    Dim i As Integer 
    For i = 1 To Len(invalidChars) 
        strName = Replace(strName, Mid(invalidChars, i, 1), "_") 
    Next i 
     
    ' Trim any trailing spaces or dots from the file name 
    Do While Right(strName, 1) = " " Or Right(strName, 1) = "." 
        strName = Left(strName, Len(strName) - 1) 
    Loop 
     
    ' Return the cleaned name 
    CleanFileName = strName 
End Function