Outlook, returning email address on IF

[markvenis]

I am trying to get a macro to send an email to all emails in range where the cell to the left of the address = N but seem to be going round in circles and not quite getting it to work.

At the moment I am using the following code, all the Outlook bits work fine i.e. opening the template adding the recipient etc it is setting the recipo value I am having problems with.

The data on sheet CB Emails is as follows

A B

me@mycompany1.com N
me1@mycompany1.com Y
me2@mycompany1.com N

I would like to send an individual mail to each recipient where B=N, my current code is as follows.

_____________________________________________________

Sub chase()

• Sheets("CB Emails").Select
  For pers = 1 To Range("A65536").End(xlUp).Row
  Range("pers").Activate
  Reply = ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Valu
  recip = pers.Value

If Reply = N Then

'Template email to be used'
Const MailTemplate = "P:\HR Operations\HRonly\HR Database Reporting\Cust Branch flags at payroll\Cap Badgeing\CapBadge Exercise Follow Up.oft"

'Accounts for Errors in Outlook'
On Error Resume Next
Set appOut = GetObject(, "Outlook.Application")
If appOut Is Nothing Then
Set appOut = CreateObject("Outlook.Application.")
blnCreate = True
If appOut Is Nothing Then
MsgBox "Unable to start Outlook.", vbOKOnly + vbCritical, "Send Mail"
Exit Sub
End If
End If
On Error GoTo 0

On Error Resume Next
Set OutMail = appOut.CreateItemFromTemplate(MailTemplate)
If OutMail Is Nothing Then
MsgBox "Unable to create item.", vbOKOnly + vbCritical, "Send Mail"
If blnCreate Then appOut.Quit
Set appOut = Nothing
Exit Sub
End If
On Error GoTo 0


'Attaches workbook to email, adds addresses and sends email'
With OutMail
.Recipients.Add recip
.Send
End With


If blnCreate Then appOut.Quit
Set OutMail = Nothing
Set appOut = Nothing

ActiveWindow.Close

End If

Next pers

End Sub

 

[Scott Huish]

I don't know if you still need help with this or not.
I haven't actually tested this in e-mail but I have some things for you to try if you want:


The first commented out section, replace with this. Change the value in the Dim statement if more than 1000 e-mail addresses is a possibility.

Dim sendone(1000) As String
ct = 0
Sheets("CB Emails").Select
For pers = 1 To Range("A65536").End(xlUp).Row
Reply = Cells(pers, 2).Value
If Reply = "N" Then
ct = ct + 1
sendone(ct) = Cells(pers, 1).Value
End If
Next pers

In the 'Attaches workbook to email... section, replace the code with this:

'Attaches workbook to email, adds addresses and sends email'
With OutMail
For x = 1 To ct
.Recipients.Add sendone(x)
Next x
.Send
End With

Remove the Next pers before the End sub

 

[Scott Huish]

EDIT: Sorry, didn't see that you wanted individual emails, try this in this section instead:

'Attaches workbook to email, adds addresses and sends email'
With OutMail
For x = 1 To ct
.Recipients.Add sendone(x)
.Send
Next x
End With