Email individual worksheets as attachment

[nbrown6]

Hi all,

I have an issue trying to find out how to send separate worksheets to individual email addresses, and wondered if someone could point me in the right direction.

I have a project where i have managed to separate peoples individual data onto a worksheets just for them. I have created a separate list of all the names of all the worksheets which i would not like to email to each person.

I have found loads of information about emailing attachments that are not part of the workbook, but cant seem to find anything for what i want to do. Or do i simply need to save the worksheet as separate file and send it?

Thanks all

[gmayor]

You need to save the sheets as new workbooks e.g. as below. Here all the sheets in the workbook are added to a collection which is used to create the workbooks and their messages. If you have a list of sheets you can employ that to add the required sheet names to the collection. You will also need to associate the recipient addresses to the sheets, but this should get you started.


Option Explicit

Sub SendSheets()
'Graham Mayor - https://www.gmayor.com - Last updated - 20 May 2020
'Macro requires code functiom from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to start Outlook correctly
Dim olApp As Object
Dim olMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlBook As Workbook
Dim xlTemp As Workbook
Dim xlSheet As Worksheet
Dim sSheet As String
Dim sPath As String
Dim sName As String
Dim FSO As Object
Dim lngSheet As Long
Dim strFile As String
Dim oColl As Collection
Const strSubject As String = "Please find workbook attached"
Const strMessage As String = "This is the covering message text" & vbCr & vbCr & _
"which will include the default signature associated with the account" & vbCr & vbCr & _
"below this text."
Const strFullName As String = "C:\Path\Filename.xlsx" 'The fullname of the workbook

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFullName) Then
On Error Resume Next
Set xlBook = Workbooks(strFile)
If xlBook Is Nothing Then
Set xlBook = Workbooks.Open(strFullName)
End If
Else
Beep
MsgBox "Workbook not found"
GoTo lbl_Exit
End If
On Error GoTo 0

'create a collection
Set oColl = New Collection
'add the sheet name to the collection
For Each xlSheet In xlBook.Sheets
oColl.Add xlSheet.Name
Next
'close the workbook
xlBook.Close SaveChanges:=False

'start Outlook using the code function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
Set olApp = OutlookApp()
'Loop through the sheets
For lngSheet = 1 To oColl.Count
sName = oColl(lngSheet)
sPath = Environ("TEMP") & "\" & sName & ".xlsx"
'create a temporary workbook based on the original workbook
Set xlTemp = Workbooks.Add(Template:=strFullName)
Application.DisplayAlerts = False
'delete the unwanted sheets
For Each xlSheet In xlTemp.Sheets
If Not xlSheet.Name = sName Then xlSheet.Delete
Next xlSheet
'save the temporary workbook
xlTemp.SaveAs sPath
xlTemp.Close SaveChanges:=False
Application.DisplayAlerts = True
'create amessage to send the sheet
Set olMail = olApp.CreateItem(0)
With olMail
'the recipient will need to be looked up and applied here
.To = "someone@somewhere.com"
.Subject = strSubject
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
oRng.Collapse 1
oRng.Text = strMessage
.Display 'required to edit message body
.Attachments.Add sPath
'.Send 'restore after testing
End With
On Error GoTo 0
'delete the temporary file
If FSO.FileExists(sPath) Then
SetAttr sPath, vbNormal
Kill sPath
End If
Next lngSheet
lbl_Exit:
Set FSO = Nothing
Set olApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set olMail = Nothing
Set xlBook = Nothing
Set xlTemp = Nothing
Set xlSheet = Nothing
Set oColl = Nothing
Exit Sub
End Sub