VBA for Sending to a list of Emails and continue to bottom of last Row

[craigw02]

Hi there I have the attached sheet which I have started VBA coding to send emails to a list of email addresses, but I want it to continue to the bottom of the very last row of the excel spreadsheet and then stop. So far this only does the very first email address on row A1 but I also wish for it to send the email if column "G2" says "YES" down to the last row also if this makes sense?

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)

With ActiveSheet
Set rngTo = .Range("a2")
Set rngSubject = .Range("e2")
Set rngCC = .Range("c2")
Set rngBody = .Range("f2")
Set rngAttach = .Range("d2")
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
.CC = rngCC.Value
End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing

End Sub
​

 

[AlphaFrog]

Try this...

[color=darkblue]Sub[/color] CreateMail()
    
    [color=darkblue]Dim[/color] objOutlook [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Dim[/color] cell       [color=darkblue]As[/color] Range
    
    [color=darkblue]Set[/color] objOutlook = CreateObject("Outlook.Application")
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Range("A2", Range("A" & Rows.Count).End(xlUp))
        [color=darkblue]If[/color] UCase(cell.Range("G1").Value) = "YES" [color=darkblue]Then[/color]
            [color=darkblue]With[/color] objOutlook.CreateItem(0)
                .to = cell.Value
                .CC = cell.Range("C1").Value
                .Attachments.Add cell.Range("D1").Value
                .Subject = cell.Range("E1").Value
                .Body = cell.Range("F1").Value
                .Display    [color=green]'Instead of .Display, you can use .Send to send the email _
                             or .Save to save a copy in the drafts folder[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] cell
    
    [color=darkblue]Set[/color] objOutlook = [color=darkblue]Nothing[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]