VBA Code for sending different tabs with in a Workbook via Outlook

[rmazza67]

Hi - I used the below VBA code to send 1 tab within a workbook that has multiple tabs (5) via Outlook as an attachment. Lets say that I have 2 tabs that I want to be able to send via email separately or have user choose which one they want to send - tab 1 and/or tab 2. The below code lets me send tab 1 and open an Outlook email with this tab as an attachment valued out.

How do I use the below VBA code to do the same thing as it is doing for Tab 1 for Tab 2? Isnt there a way in the code to just change the name of the tab and run the macro so I can send either Tab 1 or Tab2?

Thank you!


Sub Mail_ActiveSheet()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "eCardio " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yyyy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "eCardio_Service_and_Option_Prices"
.Body = "Attached is the eCardio_Service_and_Option_Prices file"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[pbornemeier]

The code you posted (which is from Ron de Bruin's site) copies the activesheet to a new workbook and attaches it to an email. Replace the line "Activesheet.Copy" with the following code which will copy all sheets that were selected when the code is started to the new workbook.

    Dim lX As Long
    Dim aryWorksheets() As Variant
    Dim sWorksheets As String
    Dim iAnswer As VbMsgBoxResult
    
    For lX = 1 To ActiveWindow.SelectedSheets.Count
        ReDim Preserve aryWorksheets(1 To lX)
        aryWorksheets(lX) = ActiveWindow.SelectedSheets(lX).Name
        sWorksheets = sWorksheets & "     " & ActiveWindow.SelectedSheets(lX).Name & vbLf
    Next
    
    iAnswer = MsgBox("You currently have the following worksheet" & _
        IIf(ActiveWindow.SelectedSheets.Count > 1, "s", "") & " selected:" & vbLf & vbLf & _
        sWorksheets & vbLf & "Click 'OK'       if " & _
        IIf(ActiveWindow.SelectedSheets.Count > 1, "these are", "this is") & " the worksheet" & _
        IIf(ActiveWindow.SelectedSheets.Count > 1, "s", "") & " that you want to attach to the email" & vbLf & _
        "Click 'Cancel' if you want to change your selection." & vbLf & vbLf & _
        "Use Ctrl+LeftClick to select/unselect multiple worksheets", vbOKCancel, _
        "Attach Selected Worksheets?")
    If iAnswer = vbCancel Then End
    Sheets(aryWorksheets).Copy

Please use code tags when posting code (preserves indents) - see link in my sig

 

[rg400]

Hi! This code is amazing, the explanation of Ron de Bruin site is also amazing with all the optimization and I could almost adapt it to my needs, just one thing i can't find/create, i understand how to send active sheets, but as i have to send different sheets to differents destinations i would like to be able to send sheets reffered in a cell/cells.
Ecample:
On sheet1 i have a table with email addresses and names of sheets to send next to them, how do i refer instead of "activesheet" to the sheet(s) named in a specific cell?

May be i'm not clear enough, my english is in a "growing" stage...

Will feel delighted&happy if get some help on this.

 

[pbornemeier]

Option Explicit

Sub SendWorksheetsToAddresses()
    'Assumes one email address in each cell in column A starting with row 2
    'Assumes the worksheet to be sent to the that address is in column B starting with row 2
    
    'OPERATIONAL WORK-AROUND
    'Set OutApp = GetObject(, "Outlook.Application")
    'The first time the code processes the above line in the Mail_ActiveSheet module it will raise error 429.
    'Click 'Debug' then press 'F5' key to reprocess this line and continue
    
    'OUTLOOK WARNING: If the email address is not correct then Outlook will use your email address book
    '  and use the closest to the incorrect address
    
    'Extension note:
    'The email body and subject are hard coded.  If you want to have a different subject/body
    '  for each email, add additional columns to Sheet1 and extend the code to extract those values
    
    Dim lRowIndex As Long
    Dim sAddress As String
    Dim sWorksheet As String
    Dim lLastRow As Long
    Dim OutApp As Object
    Dim OutMail As Object
    
    ThisWorkbook.Activate
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    OutMail.Display
    OutMail.Subject = "This is a dummy email that is needed to make working with Outlook in the next module a bit easier"
    
    With Worksheets("Sheet1")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRowIndex = 2 To lLastRow
            sAddress = .Cells(lRowIndex, 1).Value
            sWorksheet = .Cells(lRowIndex, 2).Value
            Worksheets(sWorksheet).Select
            Mail_ActiveSheet sAddress
        Next
    End With
    
    OutMail.Delete  'Delete the dummy email
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    
End Sub

Sub Mail_ActiveSheet(sAddress As String)
    'Adapted from http://www.rondebruin.nl/win/s1/outlook/mail.htm
    
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set Sourcewb = ActiveWorkbook
    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    
    'Ensure copied cells contain only values, not formulas
    With Destwb.Sheets(1).UsedRange
        .Cells.Copy
        .Cells.PasteSpecial xlPasteValues
        .Cells(1).Select
    End With
    Application.CutCopyMode = False
    
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "eCardio " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yyyy-hh-mm-ss")

    'Find open instance of outlook
    Set OutApp = GetObject(, "Outlook.Application")
    'The first time the code processes the above line it will raise error 429.
    'Click 'Debug' then press 'F5' key to reprocess this line and continue
    'I tried various things to prevent this but could not figure one out
    '  DoEvents
    '  Application.Wait (Now() + 2.31481481481481E-05) 'Wait 2 seconds so the message has a chance to become visible
    '  Error trap of 429 (Application not running); OutApp.CreateItem fails????
    
    Set OutMail = OutApp.CreateItem(0)
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .Display
            .To = sAddress
            .CC = ""
            .BCC = ""
            .Subject = "eCardio_Service_and_Option_Prices"
            .Body = "Attached is the eCardio_Service_and_Option_Prices file"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            
             
            'Uncomment one or the other of the following 2 lines
            .Display    'to show and require manual send for each email
            '.Send       'to send each email immediately
            
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
    
    'Delete the file you have sent
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    
End Sub

 

[Small Paul]

Thanks rmazza67 for the question (I have been searching for a solution to this) and pbornemeier for the solution.
Can I just clarify:
- does the code take every worksheet in the workbook and email that to the email address given in cells A2:A*?
- the sheet it sends has the sheet name in cells B2:B*?
Small Paul.

 

[pbornemeier]

Code as is sends the single worksheet specified in a column B cell to the single address specified in the corresponding column A cell.