Sending multiple attachments from excel sheet with VBA - vba

Question

I have the existing code to send a mail from a Sheet in my Excel file -
Sub CreateMail()
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)
Application.ScreenUpdating = False
Worksheets("Mail List").Activate
With ActiveSheet
Set rngTo = .Range("B1")
Set rngSubject = .Range("B2")
Set rngBody = .Range("B3")
Set rngAttach = .Range("B4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.body = rngBody.Value
.Attachments.Add rngAttach.Value
.display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
However, I want to include a number of attachments, and hence the
Set rngAttach = .Range("B4") does not help to do this.
Any help on this?
Thanks in advance!

Answer 1

Enclose your .Attachments.Add statement in loop. Something like below might work
For i = 4 To 6
.Attachments.Add Range("B" & i).Value
Next i

Answer 2

To make it Dynamic you can set the upper limit of i to the last row in Column B
For i = 4 To Range("B" & rows.count).end(xlUp).row
.Attachments.Add Range("B" & i).Value
Next i

Answer 3

This updated code:
Looks for file names from B4
Uses Dir to ensure the attached files actually exist at the specified path
Tidies up the worksheet code (Activate is unnecessary)
Sub CreateMail()
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 rng2 As Range
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Application.ScreenUpdating = False
Set ws = Worksheets("Mail List")
With ws
Set rngTo = .Range("B1")
Set rngSubject = .Range("B2")
Set rngBody = .Range("B3")
Set rngAttach = ws.Range(ws.[b4], ws.Cells(Rows.Count, "B").End(xlUp))
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.body = rngBody.Value
For Each rng1 In rngAttach.Cells
If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
Next
.display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub