Sending multiple email using range with attachment in VBA - excel

Question

This is the first time I am trying from Excel to send email using VBA code.
Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also
A (col) B C D E F G
Sl.No First Name To Email CC Email Subj File to Send Message
Code:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.
I am struggling here to find how to send for multiple email with attachment using the tested code.

Answer 1

Maybe Try this:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
For i = 2 To 21 ' Loop from 2 to 21
With ActiveSheet
Set rngTo = .Range("C" & i)
Set rngSubject = .Range("E" & i)
Set rngBody = .Range("G" & i)
Set rngAttach = .Range("F" & i)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
.Attachments.Add rngAttach.Value
.Display
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
You can loop through the Range to generate 20 emails.
Update
Added .HTMLBody instead of .Body to make text Bold And Underlined
You can use more HTML commands to make certain portions of the Text Bold and More.

Answer 2

Try it this way.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Answer 3

You need a loop for that. The below code will start with the second row and continue until it finds an empty row.
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
With ActiveSheet
Set rngTo = .Range("C" & r)
Set rngSubject = .Range("E" & r)
Set rngBody = .Range("G" & r)
Set rngAttach = .Range("F" & r)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
.Send ' If you want to send it without clicking
End With
Next
End Sub
Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions
Update
Sorry this line has to be inside the loop, I updated the code:
Set objMail = objOutlook.CreateItem(0)