Sending multiple attachments from excel sheet with 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