(VBA) Email excel attachments in one email rather than separately.

Hi can anyone help me with a problem I have. I want the Ron de Bruin code for emailing every sheet to be able to email multiple sheets to one person. For example, I have 150 sheets, and there will be 12 recipients. Rather than 150 emails being sent, I want each recipient to receive all their attachments in 1 email. So i'd be sending a total of 12 emails rather than 150. Is anyone able to help? Many thanks

Code:

---

Sub Mail_Every_Worksheet()'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    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
   
    Application.DisplayAlerts = False
   
  For Each sh In ActiveWorkbook.Worksheets
        With sh.Range("B7:D7")
            .HorizontalAlignment = xlLeft
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
        End With
    Next sh
 
    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 ActiveWorkbook.Worksheets
        If sh.Range("A1").Value Like "?*@?*.?*" Then
            sh.Copy
            Set wb = ActiveWorkbook
            TempFileName = "Sheet " & sh.Name
            Set OutMail = OutApp.CreateItem(0)
            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next
                With OutMail
                    .to = sh.Range("A1").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
    Application.DisplayAlerts = True
End Sub

---

.
Please advise if the following is accurate :

Your workbook has a total of 150 sheets.

You want to save the values in B7:D7 from each sheet into a single workbook and attach that workbook to an email.

The email is going to 12 separate individuals.

The email addresses are listed in Col A of Sheet #1 or may be listed on a separate sheet.

Hi, the current workbook has 150 sheets but this can vary from month to month. I want the full sheet emailed to the person who's email address is in cell A1 on every sheet. Currently this creates 150 emails to the 12 unique email addresses used across the 150 sheets. I'd like 12 emails created attaching each sheet relevant to that email address. Does that make sense? Thanks

As an example sheet1 emails to Joe, sheet2 emails to Jane, sheet3 emails to Joe, sheet 4 emails to Jane. Currently Joe and Jane would receive 2 emails each containing the sheet where their email address is in cell A1. I want Jane and Joe to receive 1 email each containing both of their attachments.

Quote:

---

Originally Posted by leemcder

Hi, the current workbook has 150 sheets but this can vary from month to month. I want the full sheet emailed to the person who's email address is in cell A1 on every sheet. Currently this creates 150 emails to the 12 unique email addresses used across the 150 sheets. I'd like 12 emails created attaching each sheet relevant to that email address. Does that make sense? Thanks

---

Gotcha

.
These macros to be pasted into a regular module :

Code:

---

Option Explicit


Sub CreateNewWB()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim c As Range
    Dim x As Integer
    Dim FName As String
    Dim FPath As String
    Dim NewBook As Workbook
    Dim wbPaste As Workbook
       
    Application.ScreenUpdating = False
    FPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"    'Change this line to your path
 
    For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
        If c.Value <> "" Then
            Set NewBook = Workbooks.Add
            NewBook.SaveAs FPath & c.Value & ".xlsx"
        End If
    Next c
   
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
   
    x = 1
   
    For Each ws In Worksheets
        If ws.Name <> "Email List" Then 'You may need to change this line to reflect a different "Main" Sheet
            With ws
                For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
                    Set wbPaste = Workbooks.Open(FPath & c.Value & ".xlsx")
                    If ws.Range("A1").Value = c.Value Then
                            ws.Copy After:=wbPaste.Sheets(wbPaste.Sheets.Count)
                           
                            'Workbooks(wbPaste).Activate
                            ActiveSheet.Name = ActiveSheet.Range("A1").Value & " " & x
                            ActiveWorkbook.Close True
                    End If
                    x = x + 1
                 
                Next c
               
            End With
        End If
    Next
    Application.ScreenUpdating = True
   
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
   
LoopAllFilesInFolder
End Sub


Sub LoopAllFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


myPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"
myExtension = "*.xls*"


myFile = Dir(myPath & myExtension)
Do While myFile <> ""
If Len(myFile) = 0 Then Exit Do
Set wb = Workbooks.Open(fileName:=myPath & myFile)
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete


wb.Close SaveChanges:=True


myFile = Dir
Loop


'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


Send_Email


End Sub


Sub Send_Email()


    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
   
    For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
        Set OutLookApp = CreateObject("Outlook.application")
        Set OutLookMailItem = OutLookApp.CreateItem(0)
        With OutLookMailItem
                .To = c.Value
                .CC = "Your CC here"
                .BCC = "test"
                .Subject = "This is the Subject line"
                .HTMLBody = "Hi there"
                .Attachments.Add Environ("USERPROFILE") & "\Desktop\EmailGroup\" & c.Offset(i, 1).Value
                .Display
                '.Send
        End With
    Next c


End Sub

---

See instructions on first sheet of download file ...

Thank you for taking the time to do this for me. Its very much appreciated. Apologies for the late reply. This is excellent.:)

Quote:

---

Originally Posted by Logit

.
These macros to be pasted into a regular module :

Code:

---

Option Explicit


Sub CreateNewWB()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim c As Range
    Dim x As Integer
    Dim FName As String
    Dim FPath As String
    Dim NewBook As Workbook
    Dim wbPaste As Workbook
       
    Application.ScreenUpdating = False
    FPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"    'Change this line to your path
 
    For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
        If c.Value <> "" Then
            Set NewBook = Workbooks.Add
            NewBook.SaveAs FPath & c.Value & ".xlsx"
        End If
    Next c
   
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
   
    x = 1
   
    For Each ws In Worksheets
        If ws.Name <> "Email List" Then 'You may need to change this line to reflect a different "Main" Sheet
            With ws
                For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
                    Set wbPaste = Workbooks.Open(FPath & c.Value & ".xlsx")
                    If ws.Range("A1").Value = c.Value Then
                            ws.Copy After:=wbPaste.Sheets(wbPaste.Sheets.Count)
                           
                            'Workbooks(wbPaste).Activate
                            ActiveSheet.Name = ActiveSheet.Range("A1").Value & " " & x
                            ActiveWorkbook.Close True
                    End If
                    x = x + 1
                 
                Next c
               
            End With
        End If
    Next
    Application.ScreenUpdating = True
   
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
   
LoopAllFilesInFolder
End Sub


Sub LoopAllFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


myPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"
myExtension = "*.xls*"


myFile = Dir(myPath & myExtension)
Do While myFile <> ""
If Len(myFile) = 0 Then Exit Do
Set wb = Workbooks.Open(fileName:=myPath & myFile)
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete


wb.Close SaveChanges:=True


myFile = Dir
Loop


'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


Send_Email


End Sub


Sub Send_Email()


    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
   
    For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
        Set OutLookApp = CreateObject("Outlook.application")
        Set OutLookMailItem = OutLookApp.CreateItem(0)
        With OutLookMailItem
                .To = c.Value
                .CC = "Your CC here"
                .BCC = "test"
                .Subject = "This is the Subject line"
                .HTMLBody = "Hi there"
                .Attachments.Add Environ("USERPROFILE") & "\Desktop\EmailGroup\" & c.Offset(i, 1).Value
                .Display
                '.Send
        End With
    Next c


End Sub

---

See instructions on first sheet of download file ...

---

.
You are welcome.