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

[patekos]

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

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...

chandoo.org

as well as

Posting a sample workbook

The Chandoo.org Forum now has the facilities to upload files directly into a post. Simply use either the Media icon in the Edit menu or the Upload a File Button next to the Save Changes button Alternatively In the Chandoo.org Blog or here in the Forums you can still upload files using a Free...

chandoo.org

to refresh Your memory how to
>>> use code - tags <<<

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

 

[Logit]

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