• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Excel VBA - Send email with mmultiple based on criteria (criteria value in column cell)

patekos

New Member
Hi,
I had the following VBA code to send emails with multiple attachments (pdf) to recipients depending on a value existing in column C. If column C has the same value the attachments in column G will be sent together to the same email recipiente (column F), but it's not working well.
Criteria:
Column C; and is sorted.
Path to pdf file:
Column G;
Email recipiente: Column F.

Any help is much appreciated.

code:

Reread Forum rules
as well as
to refresh Your memory how to
>>> use code - tags <<<

Code:
Sub Envia_Emails1_c()
   Dim OutApp As Object
   Dim OutMail As Object
   Dim sh As Worksheet
   Dim cell As Range
   Dim rng As Range
   Dim FilePath As String
   Dim email_corpo As String
   Dim email_assunto As String
   Dim r As Long
   Dim f As Boolean
  
   email_corpo = Range("email_corpo")
   email_assunto = Range("email_assunto")

   Application.EnableEvents = False
   Application.ScreenUpdating = False
  
   Set sh = Sheets("Colaboradores")
 
On Error Resume Next
   Set OutApp = CreateObject(Class:="Outlook.Application")
 
If OutApp Is Nothing Then
       f = True
       Set OutApp = CreateObject(Class:="Outlook.Application")
   End If
   On Error GoTo 0
  
   For Each cell In sh.Columns("F").Cells.SpecialCells(xlCellTypeConstants)
       r = cell.Row+1
       If sh.Cells(r, "C").Value <> sh.Cells(r - 1, "C").Value Then
           If Not OutMail Is Nothing Then
               OutMail.Send
               Set OutMail = Nothing
           End If
           If cell.Value Like "?*@?*.?*" Then
               Set OutMail = OutApp.CreateItem(0)
               OutMail.SendUsingAccount = OutApp.Session.Accounts.Item(1)
               OutMail.To = cell.Value
               OutMail.Subject = email_assunto
               OutMail.Body = email_corpo
           End If
       End If
       FilePath = Cells(r, "G").Value ' path do ficheiro
       If Dir(FilePath) <> "" And Not OutMail Is Nothing Then
           OutMail.Attachments.Add FilePath
       End If
   Next cell
  
   ' Last email
   If Not OutMail Is Nothing Then
       OutMail.Send
       Set OutMail = Nothing
   End If
  
   If f Then
       OutApp.Quit
   End If
   Set OutApp = Nothing
End Sub
 
Last edited by a moderator:

Logit

Active Member
Code:
Option Explicit

Sub Send_Email()

    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
   
    For Each c In Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Cells
        If c.Value = "X" Then  '<-- edit your requirement here
            Set OutLookApp = CreateObject("Outlook.application")
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            With OutLookMailItem
                    .To = c.Offset(i, 3).Value
                    .CC = "Your CC here"
                    .BCC = "test"
                    .Subject = "Your Subject here"
                    .HTMLBody = "Your Body content here"
                    .Attachments.Add c.Offset(i, 4).Value
                    .Display
                    '.Send
            End With
        End If
    Next c

End Sub
 
Top