Create work from each tab then email it
Paul H was very helpful in getting me some code to separate my data into sheets based on a name. After I get that macro ran I would want to create a workbook for each tab and send it via outlook as an attachment. I would want to have a way to keep a list of the sheet first names and corresponding email addresses and send the corresponding sheet as a workbook. I was able to find this code but it appears it only sends one sheet and has input boxes that ask for name and email addresses.
Thanks again Paul for the previous help.
Code:
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
