Create work from each tab then email it

[austenr]

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.


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

[Paul_Hossler]

I was expecting the request for separate workbooks and maybe email :) -- It seemed like a logical thing to do

Add email addresses to Rules, Col F and see if it works

I deleted all but 5 names to test and I could email all 5 to myself

[austenr]

Thanks very much. Can we integrate this into the sub that does the split by name? run the one that emails after splitting the sheets into diff names automatically? Or just create a new sub and call the two?

[austenr]

Never mind.. I see where you call the email sub. Thanks a bunch. This will save a lot of time. Will mark solved after testing. :thumb

[austenr]

Never mind.. I see where you call the email sub. :thumb

[Paul_Hossler]

Also, I left the User worksheets in the macro workbook, and the User workbooks in the same folder.

They can be deleted or recycled if you want