VBA: Sending an email with PDF attachment separately to multiple recipients

[Baggio]

Hi everyone!

I have a code which convert Excel sheet to a PDF-file and send it to the address list (Range L17:L26). This works fine but is it possible to send these emails separately to each recipient? Here are the code which I'm using now:

Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
  Dim EmailAddr As String
  Dim Cell As Range
 


  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & Range("A27").Value & " " & Range("E27").Value & ".pdf"
 
  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
  
  'Loop through the rows
    For Each Cell In Range("L17:L26").Cells
        If Cell.Value Like "*@*" Then
            EmailAddr = EmailAddr & ";" & Cell.Value
        End If
    Next
 
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
    ' Prepare e-mail
    .Subject = "Subject X - " & Range("A27").Value & " " & Range("E27").Value & ""
    .To = EmailAddr
    .CC = ""
    .Body = "Body"
    .Attachments.Add PdfFile
   
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "Message X", vbExclamation
    Else
      MsgBox "Message Y", vbInformation
    End If
    On Error GoTo 0
   
  End With
 
  ' Delete PDF file
  Kill PdfFile
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
 
End Sub

Thanks for you help!

 

[daverunt]

Hi,

Untested but try the following couple of changes.

  'Loop through the rows
    For Each Cell In Range("L17:L26").Cells
        If Cell.Value Like "*@*" Then
            EmailAddr =  Cell.Value            '----------------------- just one recipient
        End If

.....................................



 End With
Next '----------------------- next moved to after mail
 
  ' Delete PDF file
  Kill PdfFile

 

[Norie]

Try this.

Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim EmailAddr As String
Dim Cell As Range

    ' Define PDF filename
    PdfFile = ActiveWorkbook.FullName
    
    i = InStrRev(PdfFile, ".")
    
    If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    
    PdfFile = PdfFile & "_" & Range("A27").Value & " " & Range("E27").Value & ".pdf"
    
    ' Export activesheet as PDF
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
    
    
    ' Use already open Outlook if possible
    On Error Resume Next
    
    Set OutlApp = GetObject(, "Outlook.Application")
    
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
    
    OutlApp.Visible = True
    On Error GoTo 0
        
    'Loop through the rows
    For Each Cell In Range("L17:L26").Cells
        If Cell.Value Like "*@*" Then
            EmailAddr = Cell.Value
            
            ' Prepare e-mail with PDF attachment
            With OutlApp.CreateItem(0)
                
                ' Prepare e-mail
                .Subject = "Subject X - " & Range("A27").Value & " " & Range("E27").Value & ""
                .To = EmailAddr
                .CC = ""
                .Body = "Body"
                .Attachments.Add PdfFile
                
                ' Try to send
                On Error Resume Next
                .Send
                Application.Visible = True
                If Err Then
                    MsgBox "Message X", vbExclamation
                Else
                    MsgBox "Message Y", vbInformation
                End If
                On Error GoTo 0
                
            End With
        End If
        
    Next Cell
    ' Delete PDF file
    Kill PdfFile
    
    ' Quit Outlook if it was created by this code
    If IsCreated Then OutlApp.Quit
    
    ' Release the memory of object variable
    Set OutlApp = Nothing
 
End Sub

 

[Baggio]

Thank you very much Norie! This works perfectly! I just love this site.