VBA to send 1 email containing all attachments

[leemcder]

Hi, I am using this macro to email every sheet in a workbook but can anyone tell me what lines I need to add/amend so if a person is receiving more than 1 sheet, they will only get 1 email containing several attachments and not say 10 emails. I will be emailing hundreds of sheets to several people but I just want each person to receive 1 email each containing all their attachments.? Thanks



Sub Mail_Every_Worksheet()
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & ""
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A2").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = sh.Range("A2").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[Jacob Hilderbrand]

Hi

So you are copying the sheet to a new workbook and saving it, then emailing it. To group them you would need to first look through all the sheets to get the unique values from A2 which is the email. Then I would do a loop and look for each email and copy that to a new workbook then email it.

Here is a rough example.


Dim i As Long
Dim n As Long
Dim WB
Dim EmailList As New Collection


'Assuming Email List has been populated

n = EmailList.Count
For i = 1 To n
Set WB = Workbooks.Add(1)
For Each WS In Worksheets
If WS.Range("A2").Value = EmailList(i) Then
WS.Copy After:=WB.Sheets(WB.Sheets.Count)
End If
Next

If WB.Sheets.Count = 1 Then
'No new sheets were added, do not email
Else
'Save and email code here
End If

WB.Close
next i

[leemcder]

Hi

So you are copying the sheet to a new workbook and saving it, then emailing it. To group them you would need to first look through all the sheets to get the unique values from A2 which is the email. Then I would do a loop and look for each email and copy that to a new workbook then email it.

Here is a rough example.


Dim i As Long
Dim n As Long
Dim WB
Dim EmailList As New Collection


'Assuming Email List has been populated

n = EmailList.Count
For i = 1 To n
Set WB = Workbooks.Add(1)
For Each WS In Worksheets
If WS.Range("A2").Value = EmailList(i) Then
WS.Copy After:=WB.Sheets(WB.Sheets.Count)
End If
Next

If WB.Sheets.Count = 1 Then
'No new sheets were added, do not email
Else
'Save and email code here
End If

WB.Close
next i


Thank you very much for your help, this is what I was looking for. I appreciate your help!