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
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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!
