Consulting

Results 1 to 6 of 6

Thread: Create work from each tab then email it

  1. #1
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location

    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.

    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


    Peace of mind is found in some of the strangest places.

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,702
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    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?
    Peace of mind is found in some of the strangest places.

  4. #4
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    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.
    Peace of mind is found in some of the strangest places.

  5. #5
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    Never mind.. I see where you call the email sub.
    Last edited by austenr; 06-22-2019 at 09:42 AM. Reason: duplicate post
    Peace of mind is found in some of the strangest places.

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,702
    Location
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •