CODEWITHSUNDEEP
excelvba
user3682157
user3682157

Reputation: 1695

How to have multiple "For/Each" Loops Running In Excel VBA

I'm automating a VBA email attachment script from an excel doc. The data set looks like this

 File Name      Email     Body
 Sample 1       john@     Hello!
 Sample 2       mary @    Hello!

What I'm trying to do is tell excel to create an email to each person under the "email" column, then write the text in the "Body" column in the body of the email, then find and attach a file who's name is found under the "file name" column. So John@ would get an email with a body of "Hello!" and the Sample 1 attachment.

This will require THREE separate for each loops which is puzzling me:

Here is my code so far but all this does is find the attachment:

Sub Attachment()


Dim colb As Range, mycell As Range, mycell2 As Range, mycell3 As Range
Set colb = Range(Range("B2"), Range("B2").End(xlDown))
Set colc = Range(Range("C2"), Range("C2").End(xlDown))
Set cold = Range(Range("D2"), Range("C2").End(xlDown))


For Each mycell In colb

Dim path As String
path = mycell.Value


Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    Set myAttachments = OutMail.Attachments

On Error Resume Next
With OutMail
    .To = ""
    .CC = ""
    .BCC = ""
    .Subject = "Test"
    .Body = ""
    .Display
End With
On Error GoTo 0

myAttachments.Add "C:\R\" & path

Set OutMail = Nothing
Set OutApp = Nothing

Next

End Sub

Upvotes: 0

Views: 406

Answers (1)

Dan Donoghue
Dan Donoghue

Reputation: 6206

I am not 100% sure what you are saying as I don't see the need for 3 loops. Can you not just update the code to this?

With OutMail
    .To = mycell.Offset(0, 1).Text
    .CC = ""
    .BCC = ""
    .Subject = "Test"
    .Body = mycell.Offset(0, 2).Text
    .Display
End With

This will reference and offset from mycell to get the recipient and body

In which case you could chop the entire routine down to:

Sub Attachment()
Dim colb As Range, mycell As Range
Set colb = Range(Range("B2"), Range("B2").End(xlDown))
For Each mycell In colb
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    Set myAttachments = OutMail.Attachments
    On Error Resume Next
    With OutMail
        .To = mycell.Offset(0, 1).Text
        .Subject = "Test"
        .Body = mycell.Offset(0, 2).Text
        .Display
    End With
    myAttachments.Add "C:\R\" & mycell.Text
    Set OutMail = Nothing
    Set OutApp = Nothing
    Next
End Sub

Upvotes: 1

Related Questions