VBA – Send Worksheets by Email as Separate Workbooks

This code saves a worksheet as a new workbook and creates an email in Outlook with the new workbook attached. It’s very useful if you have a standardized template spreadsheet that is used across your organization.

For a more simple example, look at How to Send Email from Excel

Save Worksheet as New Workbook and Attach to Email

Sub Mail_Workbook()
Application.DisplayAlerts = False
Application.enableevents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim OutApp As Object
Dim OutMail As Object
Dim FilePath As String
Dim Project_Name As String
Dim Template_Name As String
Dim ReviewDate As String
Dim SaveLocation As String
Dim Path As String
Dim Name As String

'Create Initial variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Project_Name = Sheets("sheet1").Range("ProjectName").Value
Template_Name = ActiveSheet.Name

'Ask for Input used in Email
ReviewDate = InputBox(Prompt:="Provide date by when you'd like the submission reviewed.", Title:="Enter Date", Default:="MM/DD/YYYY")

If ReviewDate = "Enter Date" Or ReviewDate = vbNullString Then GoTo endmacro

'Save Worksheet as own workbook
Path = ActiveWorkbook.Path
    Name = Trim(Mid(ActiveSheet.Name, 4, 99))


Set ws = ActiveSheet
Set oldWB = ThisWorkbook

SaveLocation = InputBox(Prompt:="Choose File Name and Location", Title:="Save As", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ".xlsx")

    If Dir(SaveLocation) <> "" Then
    MsgBox ("A file with that name already exists. Please choose a new name or delete existing file.")
    SaveLocation = InputBox(Prompt:="Choose File Name and Location", Title:="Save As", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ".xlsx")
    End If
    
If SaveLocation = vbNullString Then GoTo endmacro

'unprotect sheet if needed
ActiveSheet.Unprotect Password:="password"

Set newWB = Workbooks.Add

'Adjust Display
ActiveWindow.Zoom = 80
ActiveWindow.DisplayGridlines = False

'Copy + Paste Values
oldWB.Activate
oldWB.ActiveSheet.Cells.Select
Selection.Copy
newWB.Activate
newWB.ActiveSheet.Cells.Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
     
'Select new WB and turn off cutcopy mode
    newWB.ActiveSheet.Range("A10").Select
    Application.CutCopyMode = False
    
'Save File
    newWB.SaveAs Filename:=SaveLocation, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

FilePath = Application.ActiveWorkbook.FullName
    
'Reprotect oldWB
oldWB.ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True _
     , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
       AllowFormattingRows:=True

'Email
On Error Resume Next
With OutMail
.to = "email@email.com"
.CC = ""
.BCC = ""
.Subject = Project_Name & ": " & Template_Name & " for review"
.Body = "Project Name: " & Project_Name & ", " & Name & " For review by " & ReviewDate
.Attachments.Add (FilePath)
.Display
' .Send      'Optional to automate sending of email.
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

'End Macro, Restore Screenupdating, Calcs, etc...
endmacro:
Application.DisplayAlerts = True
Application.enableevents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub