Excel VBA Copy Each Sheet to a Workbook

Start with a Macro

Create a Macro-Enable Workbook (*.xlsm) — mine had worksheets called Alpha, Bravo & Charlie.

To start with, I recorded the following Macro in my workbook:

1. Activate the Developer ribbon
2. Create a new Macro named WorkBookSpliitter
3. Double left-click the first tab you want to copy
4. Copy the tab name using the keyboard shortcut Ctrl + C
5. Press Enter
6. Right-click the same tab and select Move or Copy…
7. Select the Create a copy option
8. Select the (new book) option from the Move selected sheets To book dropdown
9. The new workbook will open with a copy of the worksheet
10. Select Save as from the File menu, paste the name of the sheet tab from the Clipboard into the File name textbox using the Ctrl + V keyboard shortcut
11. Click Save
12. Close the workbook
13. Click on the Stop Recording button

The above steps result in the following code:

Sub WorkBookSpliitter()
'
' WorkBookSpliitter Macro
'

'
    Sheets("Alpha").Select
    Sheets("Alpha").Copy
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Mister Fox\Dropbox\VBA & code projects\WorkbookToSheets\Alpha.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

Test ☑

I modified SaveAs Filename to: “Alpha.xlsx” to make the code more portable and added Option Explicit

Option Explicit

Sub WorkBookSpliitter()
'
' WorkBookSpliitter Macro
'

'
    Sheets("Alpha").Select
    Sheets("Alpha").Copy
    ActiveWorkbook.SaveAs Filename:= "Alpha.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

Test ☑

Loop-da-loop

Next, I searched for some code to iterate (loop) through each sheet in a workbook. The MsgBox is simply to make the loop “visible”. I adapted the following code from the Microsoft Support site. ^[1]

Sub WorksheetLoop()

' Declare CurrentSheet as a worksheet object variable.
Dim CurrentSheet As Worksheet

    ' Loop through all the worksheets in the active workbook.
    For Each CurrentSheet In Worksheets

        ' This line displays the worksheet name in a message box.
        MsgBox CurrentSheet.Name

        ' Insert your code here.

    Next

End Sub

I then pasted the code in the same Module below my Macro code from Step 1.

Test ☑

Refactor

I moved the Macro code from Step 1 into the loop in Step 2. Next, I modified the code, replacing the name of the sheet from the original Macro with CurrentSheet.Name

Option Explicit

Sub WorksheetLoop()

' Declare CurrentSheet as a worksheet object variable.
Dim CurrentSheet As Worksheet

    ' Loop through all the worksheets in the active workbook.
    For Each CurrentSheet In Worksheets

        Sheets(CurrentSheet.Name).Select
        Sheets(CurrentSheet.Name).Copy
        ActiveWorkbook.SaveAs Filename:= CurrentSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ' This line displays the worksheet name in a message box.
        MsgBox CurrentSheet.Name
    Next

End Sub

Test ☑

A quick cleanup: we don’t actually need to Select the worksheet before we copy it (and this will slow the process down), and the MsgBox was just to indicate to us what was happening while we were developing our solution.

Option Explicit

Sub WorksheetLoop()

' Declare CurrentSheet as a worksheet object variable.
Dim CurrentSheet As Worksheet

    ' Loop through all of the worksheets in the active workbook.
    For Each CurrentSheet In Worksheets
        Sheets(CurrentSheet.Name).Copy
        ActiveWorkbook.SaveAs Filename:= CurrentSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook, _
                                CreateBackup:=False
        ActiveWindow.Close
    Next

End Sub

Test ☑

MIA

You will discover that although everything seems to be running smoothly at this stage, your new files are nowhere to be found! This is because they are being saved in Excel’s default save directory, which is most likely Documents. The below version of the code will save the new workbooks in the same directory as the original workbook:

Option Explicit

Sub WorksheetLoop()

' Declare CurrentSheet as a worksheet object variable.
Dim CurrentSheet As Worksheet
' Declare MyWorkBookLocation as string variable
Dim MyWorkBookLocation As String

' We need to store the location of our workbook
MyWorkBookLocation = ActiveWorkbook.Path

    ' Loop through all of the worksheets in the active workbook.
    For Each CurrentSheet In Worksheets
        Sheets(CurrentSheet.Name).Copy
        ActiveWorkbook.SaveAs Filename:= MyWorkBookLocation & "\" & CurrentSheet.Name & ".xlsx", _
                                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
    Next

End Sub

Use the variable to build file name to be used with the SaveAs method.

Assign the Path of the ActiveWorkbook to the MyWorkBookLocation variable

Prevent overwriting files

If you need to add a new student name to create a workbook for that student after running this, you will overwrite all the existing workbooks. To prevent this, we will refactor code from the VBA to check if the file name exists tutorial to create a function.

Function CheckFileExists(checkForFileNamed As String) As Boolean

    'return true if the file exists
    If Dir(checkForFileNamed) <> "" Then
        CheckFileExists = True
    Else
        CheckFileExists = False
    End If
    
End Function

We now need to call this function in our existing code to only create the new workbook if it does not already exist:

Option Explicit

Sub WorksheetLoop()

' Declare CurrentSheet as a worksheet object variable.
Dim CurrentSheet As Worksheet
' Declare MyWorkBookLocation as string variable
Dim MyWorkBookLocation As String

' We need to store the location of our workbook
MyWorkBookLocation = ActiveWorkbook.Path

    ' Loop through all of the worksheets in the active workbook.
    For Each CurrentSheet In Worksheets
        
        If (CheckFileExists(MyWorkBookLocation & "\" & CurrentSheet.Name & ".xlsx") = False) Then
            Sheets(CurrentSheet.Name).Copy
            ActiveWorkbook.SaveAs Filename:= MyWorkBookLocation & "\" & CurrentSheet.Name & ".xlsx", _
                                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            ActiveWindow.Close
        End If
    Next

End Sub

Next steps

We now have a working solution! But it could always be improved upon…

The next iteration must send each marksheet as an email attachment to the individual students.