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

[LukeOR]

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

[georgiboy]

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

[LukeOR]

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!

[georgiboy]

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

[LukeOR]

Georgiboy,

Once again worked perfect, exactly what I wanted,

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

:):):) thanks