Email tabs from a work to different email addresses

[Ronp1204]

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?

 

[ParamRay]

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.

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

 

[Ronp1204]

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.

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

 

[Ronp1204]

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



/