Email Each Sheet in Workbook to Unique Recipient (Provided on Each Sheet)

[rss12321]

Hello All,

I would like to find some code that will allow me to send each separate worksheet in a workbook to a separate email address (located in Cell D2 of each sheet) using Microsoft Outlook. Attached is a bare bones sample workbook with two sheets, but the actual book will have around 300 sheets. I am hoping someone can help me out by providing advice, coding, or suggestions for where to look for an answer.

Thank you,

Ryan

[Leith Ross]

Hello rss12321,

Welcome to the Forum!

Did you want the worksheet mailed as an attachment or included it in the email body?

[rss12321]

Hi Leith,

Thank you for your response. I would prefer to have the sheets mailed as attachments if possible. Thanks!

[Leith Ross]

Hello rss12321,

Copy and paste this macro into a new module in your workbook's VBA Project.

Sub EmailSheets()

    Dim Body As String
    Dim Filename As Variant
    Dim olApp As Object
    Dim Recipients As String
    Dim Subject As String
    Dim TempWks As String
    Dim Wks As Worksheet
    
        Subject = ""
        Body = ""
        
        Set olApp = CreateObject("Outlook.Application")
        
            For Each Wks In ThisWorkbook.Worksheets
            
                Recipients = Recipients & Wks.Range("D2") & ";"
                
                Filename = Environ("TEMP") & "\" & Wks.Name
                
                If Val(Application.Version) >= 12 Then
                    Wks.SaveAs Filename:=TempWks & ".xlsx", FileFormat:=51
                    TempWks = TempWks & ActiveWorkbook.Name & ";"
                Else
                    Wks.FaveAs Filename:=TempWks & ".xls", FileFormat:=4
                    TempWks = TempWks & ActiveWorkbook.Name & ";"
                End If
                                
                ActiveWorkbook.Close True
                
            Next Wks
            
            With olApp.CreateItem(0)
                .To = Recipients
                .Subject = Subject
                .Body = Body
                .Attachments.Add TempWks
            End With
                
            For Each Filename In Split(TempWks, ";")
                If Filename <> "" Then Kill TempWks
            Next Filename
    
End Sub

[rss12321]

Hello,

Thank you again for your help. Unfortunately, when I try to run this macro I receive the error message (on my excel file):

"The following features cannot be saved in macro-free workbooks:

• VB Project

To save a file with these features, click No and then choose a macro-enabled file type in the File Type list.
To continue saving as a macro-free workbook, click Yes."

If I click yes, the VBA editor produces the error message "Run-time error '1004':
Method 'Saveas' of object'_worksheet' failed"

If I click no and attempt running the macro in a macro enabled file type, the same error(s) occur.

Do you have any thoughts on this issue? Thanks!

[Leith Ross]

Hello rss12321,

Sorry for the late reply. I had to leave unexpectedly to answer a client's request. You probably need to enable macros in Excel. Here is link on how to do that...
Change Macro Security Settings In Excel 2007

Also, this version of the macro will handle most common Excel file formats. You may want to use this version instead of the previous one.

Sub EmailSheets()

    Dim Body As String
    Dim Ext As String
    Dim Filename As Variant
    Dim FileType As Long
    Dim olApp As Object
    Dim Recipients As String
    Dim Subject As String
    Dim TempFiles As String
    Dim Wks As Worksheet
    
      ' Change these to what you want to say.
        Subject = ""
        Body = ""
        
        
        Set olApp = CreateObject("Outlook.Application")
        
        FileFormat = ThisWorkbook.FileFormat
        
            Select Case FileFormat
                Case xlOpenXMLWorkbook: Ext = ".xlsx"
                Case xlOpenXMLWorkbookMacroEnabled: Ext = ".xlsm"
                Case xlOpenXMLTemplateMacroEnabled: Ext = ".xltm"
                Case xlOpenXMLTemplate: Ext = ".xltx"
                Case xlOpenXMLAddIn: Ext = ".xlam"
                Case xlWorkbookNormal: Ext = ".xls"
                Case xlTemplate: Ext = ".xlt"
                Case xlAddIn: Ext = ".xla"
                Case xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows: Ext = ".csv"
            End Select
        
            For Each Wks In ThisWorkbook.Worksheets
            
                Recipients = Recipients & Wks.Range("D2") & ";"
                
                Filename = Environ("TEMP") & "\" & Wks.Mame & Ext
                
                    Wks.SaveAs Filename, FileFormat
                    ActiveWorkbook.Close True
                    
                TempFiles = TempFiles & Filename & ";"
                
            Next Wks
            
          ' Send all the emails at once.
            With olApp.CreateItem(0)
                .To = Recipients
                .Subject = Subject
                .Body = Body
                .Attachments.Add TempFiles
            End With
                
          ' Cleanup the temporary files.
            For Each Filename In Split(TempFiles, ";")
                If Filename <> "" Then Kill Filename
            Next Filename
    
End Sub