Adding multiple recipients to email from range in sheet

owen4512

Board Regular
Joined
Dec 10, 2014
Messages
71
Hi all,

I currently have a macro that generates an email from excel. On sheet4 I have a list of recipients in range "B7:B23" and i'm looking to include all recipients in my email however i'm not sure how i adapt the below to do this. I know I can reference each cell however the specified range will increase over time. Is there an alternative to the below method?

VBA Code:
.To = Sheet4.Range("B7") & Sheet4.Range("B8").Text

The below is what i'm looking to adapt :)

VBA Code:
With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = "Please see attached." & vbNewLine & vbNewLine & "Fleet"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
For your specific case, it may be better to make Rng really dynamic especially if the range can grow beyond B23.

See if the below works

VBA Code:
Dim Rng As Range, mystr As String
 Set Rng = Worksheets("Sheet4").Range("B7:B23")
    mystr = Join(Application.Transpose(Rng.Value), ";")

    With OutlookMessage
        .To = mystr
        .CC = ""
        .BCC = ""
        .Subject = TempFileName
        .Body = "Please see attached." & vbNewLine & vbNewLine & "Fleet"
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With
 
Upvote 0
For your specific case, it may be better to make Rng really dynamic especially if the range can grow beyond B23.

See if the below works

VBA Code:
Dim Rng As Range, mystr As String
Set Rng = Worksheets("Sheet4").Range("B7:B23")
    mystr = Join(Application.Transpose(Rng.Value), ";")

    With OutlookMessage
        .To = mystr
        .CC = ""
        .BCC = ""
        .Subject = TempFileName
        .Body = "Please see attached." & vbNewLine & vbNewLine & "Fleet"
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With

Thank you for your response however it doesn't seem to have worked as the 'To' field on my email is empty. Below is my full code that might hopefully clarify where i'm going wrong :)

VBA Code:
Sub EmailSelectedSheets()

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

Dim Rng As Range, mystr As String

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Copy only selected sheets into new workbook
  Set SourceWB = ActiveWorkbook
  SourceWB.Windows(1).SelectedSheets.Copy
  Set DestinWB = ActiveWorkbook


'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox

    TempFileName = "Fleet Arrears Report"
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

 
'Determine File Extension
  If SourceWB.Saved = True Then
    FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  Else
    FileExtStr = ".xlsx"
  End If

'Break External Links
  ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

    'Loop Through each External Link in ActiveWorkbook and Break it
      On Error Resume Next
        For x = 1 To UBound(ExternalLinks)
          DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
        Next x
      On Error GoTo 0
     
'Save Temporary Workbook
  DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(Class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(Class:="Outlook.Application") 'If not, open Outlook
   
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment



  On Error Resume Next
 
    Set Rng = Worksheets("Sheet4").Range("B7:B23")
    mystr = Join(Application.Transpose(Rng.Value), ";")
 
    With OutlookMessage
     .To = mystr
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = "Please see attached." & vbNewLine & vbNewLine & "Kind regards," & vbNewLine & vbNewLine & "Fleet"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
 
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub
 
Upvote 0
Thank you for your response however it doesn't seem to have worked as the 'To' field on my email is empty. Below is my full code that might hopefully clarify where i'm going wrong :)

VBA Code:
Sub EmailSelectedSheets()

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

Dim Rng As Range, mystr As String

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Copy only selected sheets into new workbook
  Set SourceWB = ActiveWorkbook
  SourceWB.Windows(1).SelectedSheets.Copy
  Set DestinWB = ActiveWorkbook


'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox

    TempFileName = "Fleet Arrears Report"
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If


'Determine File Extension
  If SourceWB.Saved = True Then
    FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  Else
    FileExtStr = ".xlsx"
  End If

'Break External Links
  ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

    'Loop Through each External Link in ActiveWorkbook and Break it
      On Error Resume Next
        For x = 1 To UBound(ExternalLinks)
          DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
        Next x
      On Error GoTo 0
    
'Save Temporary Workbook
  DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(Class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(Class:="Outlook.Application") 'If not, open Outlook
  
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment



  On Error Resume Next

    Set Rng = Worksheets("Sheet4").Range("B7:B23")
    mystr = Join(Application.Transpose(Rng.Value), ";")

    With OutlookMessage
     .To = mystr
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = "Please see attached." & vbNewLine & vbNewLine & "Kind regards," & vbNewLine & vbNewLine & "Fleet"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing

'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub
First Question would be if Worksheets("Sheet4").Range("B7:B23") is the range where you have the recipients
 
Upvote 0
First Question would be if Worksheets("Sheet4").Range("B7:B23") is the range where you have the recipients

Apologies for the delay in my response - Yes, i currently have all recipients listed from B7 to B23 and the list is likely to grow overtime.
 
Upvote 0

Forum statistics

Threads
1,213,539
Messages
6,114,221
Members
448,554
Latest member
Gleisner2

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