Looping through a set range and email an attachment

[KNKN9]

Hi,

I am struggling to loop through my sent range to send an email via outlook with attachments.

so far I have

coloum N
email 1
email 2
email 3
email 4
email 5

Sub projtodat ()Dim OutApp As Object
Dim OutMail As Object
Dim Rng As Range
Set Rng = Range(Range("N2"), Range("N2").End(xlDown))
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
        .to = Rng
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ("C:\Users\naomie.kiwutila\Documents\ASPAC\Hong_Kong\ASPAC -  BAT 2017 Quarterly InScope & Adhoc Fee Report Hong Kong (TW).xlsx")
       .display  
    End With
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

.

So I need the email to get sent to every email in my set range.

Many Thanks in advanced !!

Naomie

 

[Norie]

Naomie

You need a semi-colon separated list of recipients, try this.

Sub projtodat()
Dim OutApp As Object
Dim OutMail As Object
Dim Rng As Range
Dim strRecipients As Variant

    Set Rng = Range(Range("N2"), Range("N2").End(xlDown))
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next

    strRecipients = Join(Application.Transpose(Rng.Value), ";")
    
    With OutMail
        .To = strRecipients
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ("C:\Users\naomie.kiwutila\Documents\ASPAC\Hong_Kong\ASPAC -  BAT 2017 Quarterly InScope & Adhoc Fee Report Hong Kong (TW).xlsx")
        .Display
    End With
    
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

 

[KNKN9]

Perfect !

This works just fine

Thanks Norie!