Consulting

Results 1 to 5 of 5

Thread: How To Save, Rename, and Send Multiple Sheets, As Separate Attachments In Outlook

  1. #1
    VBAX Newbie
    Joined
    Mar 2021
    Posts
    3
    Location

    How To Save, Rename, and Send Multiple Sheets, As Separate Attachments In Outlook

    Hey guys,
    Let me start by saying thank you for helping. You guys amaze me with how some of this code can be written, so simple, yet complex, it is most definitely an art form. I have a very limited, self taught knowledge of VBA, but I will try my best to explain my problem, or what I would like to accomplish.

    I will try to explain this the best I know how,

    I have a workbook where on the main page I create data to add to 1 of 8 sheets. The sheets are called 1, 2, 3,....8 Each sheet is basically a single page to print containing data. I want to save each of the 8 sheets as a new workbook into a folder on my computer using a value from each sheet ( lets say cell A1 ) as the file name. I would also like to load those 8 separate attachments into Outlook to send to some recipients. I would prefer to have this all set up in one macro I could run from a button. I have been able to get parts of this working, but I am having trouble tying everything together in one spot. For example: I have been able to Save the 8 sheets into a folder with the correct new filenames. And using some other code I have been able to load a single attachment into outlook (but the file name of attachment was not correct). If It helps, I will show the pieces of code I have that are working. Thanks to everyone for any help on this matter, much appreciated.


    In summary, I would like to,
    -Save each sheet (1-8) as a new workbook into a folder using value of A1 on each sheet as the filename
    -Load those 8 new workbooks as an attachment in Outlook email to send

    Here are some pieces of code I have that are working,
    The following loads a single sheet in outlook with the filename "TempRangeForEmail",
    I have been unable to get multiple files to attach, or get the filenames right.

    Sub SEND_TO_OUTLOOK() 
        'SENDS SINGLE SHEET AS ATTACHMENT IN OUTLOOK
    'VARIABLES
        Dim OLApp As Outlook.Application
        Dim OLMail As Object
    'SAVES TO NEW WORKBOOK
            Sheets("1").Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\TempRangeForEmail.xlsx"
    'STARTS OUTLOOK
        Set OLApp = New Outlook.Application
        Set OLMail = OLApp.CreateItem(0)
            OLApp.Session.Logon
        With OLMail
            .To = "WHOEVER.com"
            .CC = ""
            .BCC = ""
            .Subject = "LOADS INTO SUBJECT LINE CORRECTLY"
            .Body = "LOADS INTO BODY OF EMAIL CORRECTLY"""
            .Attachments.Add (ThisWorkbook.Path & "\TempRangeForEmail.xlsx")
            .Display
    'CHANGE TO SEND ONCE WORKING
        End With
            ActiveWorkbook.Close SaveChanges:=True
            Kill ThisWorkbook.Path & "\TempRangeForEmail.xlsx"
    'Memory Cleanup
        Set OLMail = Nothing
        Set OLApp = Nothing
    End Sub
    And this code will save each sheet correctly with the correct filename into folder but I am unsure how to load these into Outlook as attachments, Also my apologies, I realize this code is unneccesarily long, which again points to my limited knowledge of VBA. But it was working.
    To further confuse i know I mentioned cell A1 above, but this will be shown as S33 below.

    Sub SAVES_TO_FOLDER()  'SAVES SHEETS TO FOLDER AS NEW WORKBOOKS
        Application.ScreenUpdating = False
            Dim fName As String
        'SHEET 1
            fName = Sheets("1").Range("S33").Value
            Sheets("1").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 2
            fName = Sheets("2").Range("S33").Value
            Sheets("2").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 3
            fName = Sheets("3").Range("S33").Value
            Sheets("3").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 4
            fName = Sheets("4").Range("S33").Value
            Sheets("4").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 5
            fName = Sheets("5").Range("S33").Value
            Sheets("5").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 6
            fName = Sheets("6").Range("S33").Value
            Sheets("6").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 7
            fName = Sheets("7").Range("S33").Value
            Sheets("7").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        'SHEET 8
            fName = Sheets("8").Range("S33").Value
            Sheets("8").Copy
                With ActiveWorkbook
        'DESTINATION FOLDER
            .SaveAs "S:\MY FOLDERS LOCATION" & fName
            .Close
        End With
        Application.CutCopyMode = False
    End Sub
    And versions I am using,
    Microsoft® Outlook® for Microsoft 365 MSO (Version 2204 Build 16.0.15128.20158) 64-bit
    Microsoft® Excel® for Microsoft 365 MSO (Version 2204 Build 16.0.15128.20158) 64-bit

    Thank you all for your time
    Last edited by Aussiebear; 05-17-2022 at 04:15 PM. Reason: Added code tags to submitted code

  2. #2
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Hi LukeOR,

    Welcome to the forum.

    Maybe something like the below will help you on your way?

    Option Explicit
    
    Sub SEND_TO_OUTLOOK()
        Dim OLApp As Outlook.Application, OLMail As Object
        Dim fName As String, wbVar() As String
        Dim wsVar As Variant, x As Integer
        
        wsVar = Array("1", "2", "3", "4", "5", "6", "7", "8")
        ReDim wbVar(UBound(wsVar))
        For x = 0 To UBound(wsVar)
            fName = Sheets(wsVar(x)).Range("S33").Value
            Sheets(wsVar(x)).Copy
            With ActiveWorkbook
                .SaveAs ThisWorkbook.Path & "\" & fName & ".xlsx"
                .Close False
                wbVar(x) = ThisWorkbook.Path & "\" & fName & ".xlsx"
            End With
        Next x
    
        Set OLApp = New Outlook.Application
        Set OLMail = OLApp.CreateItem(0)
        OLApp.Session.Logon
        With OLMail
            .Display
            .To = "WHOEVER.com"
            .CC = ""
            .BCC = ""
            .Subject = "LOADS INTO SUBJECT LINE CORRECTLY"
            .Body = "LOADS INTO BODY OF EMAIL CORRECTLY"""
            For x = 0 To UBound(wbVar)
                .Attachments.Add wbVar(x)
                Kill wbVar(x)
            Next x
        End With
    
        Set OLMail = Nothing
        Set OLApp = Nothing
    End Sub
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  3. #3
    VBAX Newbie
    Joined
    Mar 2021
    Posts
    3
    Location
    Works Perfectly! You sir are an expert )), Thank you so much, I have been pulling my hair out for 3 days trying to get this to work. One last thing,
    I would like to add a "NAMED_RANGE" from a sheet called "DATA" to show in the Body of that email. Can this be done easily?

    I would like this to show in the body of the email, the "Named_Range" actual range is below,

    - Sheets("DATA").Range("C8:AN42").Value



    Thanks again Georgiboy, great help,

    have a great day!

  4. #4
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    With the help of a function from Ron de Bruin:
    Sub SEND_TO_OUTLOOK()    
        Dim OLApp As Outlook.Application, OLMail As Object
        Dim fName As String, wbVar() As String
        Dim wsVar As Variant, x As Integer
        
        wsVar = Array("1", "2", "3", "4", "5", "6", "7", "8")
        ReDim wbVar(UBound(wsVar))
        For x = 0 To UBound(wsVar)
            fName = Sheets(wsVar(x)).Range("S33").Value
            Sheets(wsVar(x)).Copy
            With ActiveWorkbook
                .SaveAs ThisWorkbook.Path & "\" & fName & ".xlsx"
                .Close False
                wbVar(x) = ThisWorkbook.Path & "\" & fName & ".xlsx"
            End With
        Next x
    
    
        Set OLApp = New Outlook.Application
        Set OLMail = OLApp.CreateItem(0)
        OLApp.Session.Logon
        With OLMail
            .Display
            .To = "WHOEVER.com"
            .CC = ""
            .BCC = ""
            .Subject = "LOADS INTO SUBJECT LINE CORRECTLY"
            .HTMLBody = RangetoHTML(Sheets("DATA").Range("C8:AN42"))
            For x = 0 To UBound(wbVar)
                .Attachments.Add wbVar(x)
                Kill wbVar(x)
            Next x
        End With
    
    
        Set OLMail = Nothing
        Set OLApp = Nothing
    End Sub
    
    
    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
    
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
    
        'Delete the htm file we used in this function
        Kill TempFile
    
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  5. #5
    VBAX Newbie
    Joined
    Mar 2021
    Posts
    3
    Location
    Georgiboy,

    Once again worked perfect, exactly what I wanted,

    I can't thank you enough. I owe you one, or two!

    thanks

Tags for this Thread

Posting Permissions

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