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.

Code:

---

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.

Code:

---

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

Hi LukeOR,

Welcome to the forum.

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

Code:

---

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

---

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!

With the help of a function from Ron de Bruin:

Code:

---

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

---

Georgiboy,

Once again worked perfect, exactly what I wanted,

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

:):):) thanks