VBA for sending Bulk Email with Unique Attachments in XLS to Unique Receipient

Dear Friends

Its a VBA made by one of our friend for sending bulk mails to unique mail id with unique attachments, but the same in not functioning as designed as its not picking up the attachment from defined range, can anyone suggest where the problem lies.

Code:

---

Public Sub Send_multiple_email_with_attachements()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range

On Error Resume Next

With ActiveSheet
lastrowTO = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With ActiveSheet
lastrowCC = .Cells(.Rows.Count, "B").End(xlUp).Row
End With

With ActiveSheet
lastrowBCC = .Cells(.Rows.Count, "C").End(xlUp).Row
End With

x = WorksheetFunction.Max(lastrowTO, lastrowCC, lastrowBCC)

For t = 3 To x

If ActiveSheet.Range("K" & t) = "Yes" Or ActiveSheet.Range("K" & t) = "yes" Then

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With ActiveSheet
Set rngTo = ActiveSheet.Range("A" & t)
Set rngCC = ActiveSheet.Range("B" & t)
Set rngBCC = ActiveSheet.Range("C" & t)
Set rngSubject = ActiveSheet.Range("D" & t)
Set rngBody = ActiveSheet.Range("E" & t)
Set rngAttach = ActiveSheet.Range("G" & t)
Set rngVoting = ActiveSheet.Range("J" & t)
End With

With objMail
.VotingOptions = rngVoting.Value
.To = rngTo.Value
.cc = rngCC.Value
.bcc = rngBCC.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.send
End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing

End If

Next t
End Sub

---

moreover can anyone suggest modifications if any to incorporate Mail Body in the format as below


Dear Sir,

Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices.

Thanks & Regards
Md Asif Iqbal

worked for me
use .Display to test the procedure.
use .Send to send emails.

if you dont specify the sheet of a cell, it refers to the cell in activesheet. using ActiveSheet.Range("A1") is redundant. Just Range("A1")

Code:

---

Sub vbax_59255_mass_emailing()

    Dim t As Long, LastRow As Long
    Dim mBody As String
   
    LastRow = Range("A:C").Find("*", , , , xlByRows, xlPrevious).Row
   
    mBody = "Dear Sir," & vbLf & vbLf
    mBody = mBody & "Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices." & vbLf & vbLf
    mBody = mBody & "Thanks & Regards" & vbLf
    mBody = mBody & "Md Asif Iqbal"

    With CreateObject("Outlook.Application")
        For t = 3 To LastRow
            If UCase(Range("K" & t)) = "YES" Then
                With .CreateItem(0)
                    .VotingOptions = Range("J" & t).Value
                    .To = Range("A" & t).Value
                    .CC = Range("B" & t).Value
                    .BCC = Range("C" & t).Value
                    .Subject = Range("D" & t).Value
                    .Body = mBody
                    .Attachments.Add Range("G" & t).Value
                    .Display
                    '.Send
                End With
            End If
        Next t
    End With

End Sub

---

Dear Mancubus

I incorporated your you and its working fine except the attachment part, have attached the code kindly check every thing is in order

Code:

---

Public Sub Send_multiple_email_with_attachements()
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngSubject As Range
    Dim rngAttach As Range
    Dim t As Long, Lastrow As Long
    Dim mBody As String


   
    On Error Resume Next
   
    mBody = mBody & vbLf & vbLf
    mBody = mBody & "Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices." & vbLf & vbLf
    mBody = mBody & "Thanks & Regards" & vbLf
    mBody = mBody & "Md Asif Iqbal"
   
   
   
    With ActiveSheet
        lastrowTO = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
   
    With ActiveSheet
        lastrowCC = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
   
    With ActiveSheet
        lastrowBCC = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With
   
    x = WorksheetFunction.Max(lastrowTO, lastrowCC, lastrowBCC)
   
    For t = 3 To x
       
        If ActiveSheet.Range("K" & t) = "Yes" Or ActiveSheet.Range("K" & t) = "yes" Then
           
            Set objOutlook = CreateObject("Outlook.Application")
            Set objMail = objOutlook.CreateItem(0)
           
            With ActiveSheet
                Set rngTo = ActiveSheet.Range("A" & t)
                Set rngCC = ActiveSheet.Range("B" & t)
                Set rngBCC = ActiveSheet.Range("C" & t)
                Set rngSubject = ActiveSheet.Range("D" & t)
                Set rngBody = ActiveSheet.Range("E" & t)
                             
                Set rngAttach = ActiveSheet.Range("G" & t)
                Set rngVoting = ActiveSheet.Range("J" & t)
            End With
           
            With objMail
                .VotingOptions = rngVoting.Value
                .To = rngTo.Value
                .cc = rngCC.Value
                .bcc = rngBCC.Value
                .Subject = rngSubject.Value
                .Body = rngBody & mBody
                .Attachments.Add rngAttach.Value
                .display
                .send
            End With
           
            Set objOutlook = Nothing
            Set objMail = Nothing
            Set rngTo = Nothing
            Set rngSubject = Nothing
            Set rngBody = Nothing
            Set rngAttach = Nothing
           
        End If
       
    Next t
End Sub

---

@mda
what i posted is a short for all your code.
you dont need to dim hundreds of variables for objects, methods, etc and assign values to.

post a sample cell value from which you take attachment names. or, better, post your workbook.
and dont forget to wrap your code with code tags.

Dear Mancubus

thanks for the code provided its working fine, but at time the code doesn't not run I don't know why, I'm trying to figure it out may be I'm making changes to the mail body. I just need a bit of tweaking to the code in the mail body the ones I have highlighted in RED should pick up data from the range in Column F, H & I

mBody = "Dear Sir," & vbLf & vbLf
mBody = mBody & "Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices." & vbLf & vbLf
mBody = mBody & "Thanks & Regards" & vbLf
mBody = mBody & "Md Asif Iqbal

Thanks & Regards

Md Asif Iqbal

Why did you break up with your friend ? Why don't you ask him/her ?

no. the red bits dont affect the code. there is a missing double quotes mark after Iqbal but i think it's a typo.


post your workbook. you may alter the original data. i just need to see the what type of values you have in cells.

Quote:

---

Originally Posted by snb

Why did you break up with your friend ? Why don't you ask him/her ?

---

spiritual humor. :whistle:

Dear Mancubus

Attached please find the file on which I'm applying the code, what I meant by Highlighting certain characters in red was that I wanted the field to pick up data from the Range in the xlsx file from columns E, H & I which will be different in individual cases.

Regards

Md Asif Iqbal

Works as expected.
Creates e-mails for the rows if their column K value is YES.

i modified the code to take the greeting/salutation part from column E.
so instead of Dear Sir, mail body starts with Dear Arindom, Dear Nilay, etc.

just make sure columns A, B, C contain valid e-mail addresses and column G valid full file name.
if the name of the file to attach is C:\Users\IqbalM\Desktop\BIN\AR\A.D. REGENCY EXPORTS PVT. LTD.xlsx, a file named A.D. REGENCY EXPORTS PVT. LTD.xlsx must exist in the folder C:\Users\IqbalM\Desktop\BIN\AR\.

and this codes assumes active sheet contains all the mailing info.
so run the code if Sheet1 (taking into account the uploaded file) is the activesheet.

Code:

---

Sub vbax_59255_mass_emailing()
   
    Dim t As Long, LastRow As Long
    Dim mBody As String
   
    LastRow = Range("A:C").Find("*", , , , xlByRows, xlPrevious).Row
   
    mBody = vbLf & vbLf
    mBody = mBody & "Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices." & vbLf & vbLf
    mBody = mBody & "Thanks & Regards" & vbLf
    mBody = mBody & "Md Asif Iqbal"
   
    With CreateObject("Outlook.Application")
        For t = 3 To LastRow
            If UCase(Range("K" & t)) = "YES" Then
                With .CreateItem(0)
                    .VotingOptions = Range("J" & t).Value
                    .To = Range("A" & t).Value
                    .CC = Range("B" & t).Value
                    .BCC = Range("C" & t).Value
                    .Subject = Range("D" & t).Value
                    .Body = Range("E" & t).Value & mBody
                    .Attachments.Add Range("G" & t).Value
                    .Display
                    '.Send
                End With
            End If
        Next t
    End With
   
End Sub

---

test your code with
when testing, make sure there is at least one Yes in K3:K8

Code:

---

Sub vbax_59255_mass_emailing_test()
   
    Dim t As Long, LastRow As Long
    Dim mBody As String
   
    LastRow = Range("A:C").Find("*", , , , xlByRows, xlPrevious).Row
   
    mBody = vbLf & vbLf
    mBody = mBody & "Attached please find Outstanding as on 31.3.2017. Kindly Review and settle overdue Invoices." & vbLf & vbLf
    mBody = mBody & "Thanks & Regards" & vbLf
    mBody = mBody & "Md Asif Iqbal"
   
    With CreateObject("Outlook.Application")
        For t = 3 To 8 'loop thru 3-8 rows only
            If UCase(Range("K" & t)) = "YES" Then
                With .CreateItem(0)
                    .VotingOptions = Range("J" & t).Value
                    .To = Range("A" & t).Value
                    .CC = Range("B" & t).Value
                    .BCC = Range("C" & t).Value
                    .Subject = Range("D" & t).Value
                    .Body = Range("E" & t).Value & mBody
                    .Attachments.Add Range("G" & t).Value
                    .Display 'just display do not send
                End With
            End If
        Next t
    End With
   
End Sub

---

PS: i have nothing to add regarding this thread. so i can't reply any further questions like "does not work", "works but not as expected", etc.

You data looks hard to maintain. I'd suggest something like the attached to build your email list from basic data which also checks you have a valid attachment.