Consulting

Results 1 to 8 of 8

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

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location

    (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

    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

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    Please advise if the following is accurate :

    Your workbook has a total of 150 sheets.

    You want to save the values in B77 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.

  3. #3
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location
    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

  4. #4
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location
    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 View Post
    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

  5. #5
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    Gotcha

  6. #6
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    These macros to be pasted into a regular module :

    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 ...
    Attached Files Attached Files

  7. #7
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location
    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 View Post
    .
    These macros to be pasted into a regular module :

    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 ...

  8. #8
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    You are welcome.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •