Email tabs from a work to different email addresses

Ronp1204

New Member
Joined
Jun 28, 2019
Messages
3
I have an excel workbook with multiple tabs. I am looking to send each tab to a different email address. The individual email address will be located in the same cell on each tab. Is there a VBA code that will perform this task?
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Here is the whole module, which goes in the same workbook containing the sheets to be e-mailed.

Make sure you change the line where indicated in the comments.

Code:
Private outlookApp As Object
Private newApp As Boolean

Public Sub EmailWorksheets()
  Dim emailAddress As String
  Dim tempPaths As New Collection
  Dim tempPath As String
  Dim sh As Worksheet
  Dim j As Long
  
  On Error GoTo ErrorHandler
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  InitializeOutlook
  
  For Each sh In ThisWorkbook.Worksheets
    tempPath = CopySheetToTempWorkbook(sh)
    tempPaths.Add tempPath
    emailAddress = sh.Range("A1").Text '<--- change to cell containing email address
    SendEmail emailAddress, "Subject goes here", "Body goes here", tempPath
  Next sh
  
  MsgBox tempPaths.Count & " e-mails were sent.", vbInformation

ExitHandler:
  On Error Resume Next
  TerminateOutlook
  For j = tempPaths.Count To 1 Step -1
    Kill tempPaths(j)
    tempPaths.Remove j
  Next j
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Set tempPaths = Nothing
  Set sh = Nothing
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

Private Sub InitializeOutlook()
  On Error Resume Next
  Set outlookApp = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If outlookApp Is Nothing Then
    Set outlookApp = CreateObject("Outlook.Application")
    newApp = True
  Else
    newApp = False
  End If
End Sub

Private Function CopySheetToTempWorkbook(ByVal sheetToCopy As Object) As String
  Dim tempPath As String
  tempPath = Environ("temp") & "\" & sheetToCopy.Name & ".xlsx"
  If Dir(tempPath) <> vbNullString Then Kill tempPath
  sheetToCopy.Copy
  ActiveWorkbook.SaveAs tempPath, xlOpenXMLWorkbook
  ActiveWorkbook.Close
  CopySheetToTempWorkbook = tempPath
End Function

Private Sub SendEmail( _
    ByVal toRecipient As String, _
    ByVal subjectText As String, _
    ByVal bodyText As String, _
    ByVal attachmentPath As String)
  With outlookApp.CreateItem(0)
    .to = toRecipient
    .Subject = subjectText
    .Body = bodyText
    .Attachments.Add attachmentPath
    .Send
  End With
End Sub

Private Sub TerminateOutlook()
  If newApp Then outlookApp.Quit
  Set outlookApp = Nothing
End Sub
 
Last edited:
Upvote 0
Thanks for the help this. I really appreciate it. I am still pretty new with VBA. How do I execute/run the VBA code? The code I have used in the past usually runs in the background.

Thanks



/
Here is the whole module, which goes in the same workbook containing the sheets to be e-mailed.

Make sure you change the line where indicated in the comments.

Code:
Private outlookApp As Object
Private newApp As Boolean

Public Sub EmailWorksheets()
  Dim emailAddress As String
  Dim tempPaths As New Collection
  Dim tempPath As String
  Dim sh As Worksheet
  Dim j As Long
  
  On Error GoTo ErrorHandler
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  InitializeOutlook
  
  For Each sh In ThisWorkbook.Worksheets
    tempPath = CopySheetToTempWorkbook(sh)
    tempPaths.Add tempPath
    emailAddress = sh.Range("A1").Text '<--- change to cell containing email address
    SendEmail emailAddress, "Subject goes here", "Body goes here", tempPath
  Next sh
  
  MsgBox tempPaths.Count & " e-mails were sent.", vbInformation

ExitHandler:
  On Error Resume Next
  TerminateOutlook
  For j = tempPaths.Count To 1 Step -1
    Kill tempPaths(j)
    tempPaths.Remove j
  Next j
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Set tempPaths = Nothing
  Set sh = Nothing
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

Private Sub InitializeOutlook()
  On Error Resume Next
  Set outlookApp = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If outlookApp Is Nothing Then
    Set outlookApp = CreateObject("Outlook.Application")
    newApp = True
  Else
    newApp = False
  End If
End Sub

Private Function CopySheetToTempWorkbook(ByVal sheetToCopy As Object) As String
  Dim tempPath As String
  tempPath = Environ("temp") & "\" & sheetToCopy.Name & ".xlsx"
  If Dir(tempPath) <> vbNullString Then Kill tempPath
  sheetToCopy.Copy
  ActiveWorkbook.SaveAs tempPath, xlOpenXMLWorkbook
  ActiveWorkbook.Close
  CopySheetToTempWorkbook = tempPath
End Function

Private Sub SendEmail( _
    ByVal toRecipient As String, _
    ByVal subjectText As String, _
    ByVal bodyText As String, _
    ByVal attachmentPath As String)
  With outlookApp.CreateItem(0)
    .to = toRecipient
    .Subject = subjectText
    .Body = bodyText
    .Attachments.Add attachmentPath
    .Send
  End With
End Sub

Private Sub TerminateOutlook()
  If newApp Then outlookApp.Quit
  Set outlookApp = Nothing
End Sub
 
Upvote 0
Thanks, I was able to run it and it works great.

I really appreciate the help on this!!!!



Thanks for the help this. I really appreciate it. I am still pretty new with VBA. How do I execute/run the VBA code? The code I have used in the past usually runs in the background.

Thanks



/
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top