Send Worksheets by Email as Separate Workbooks

VBA – Send Worksheets by Email as Separate Workbooks

Associated Files Download Links

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

100

101

102

103

104

105

106

107

108

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

VBA Coding Made Easy

Stop searching for VBA code online. Learn more about AutoMacro – A VBA Code Builder that allows beginners to code procedures from scratch with minimal coding knowledge and with many time-saving features for all users!