send email to email address in column

[Bobbo]

I need to be able to send a standard email to all of the email addresses in
column E. I am able to send the email If I manualy add each address to the
..To section of code. What I would like is to search column E and create a
running list of addresses that can be added to the .To section.
I am hoping to just send out one message instead of a bunch.

Thanks
Bob

 

[Ron de Bruin]

See this from my mail page
http://www.rondebruin.nl/sendmail.htm

Send to all E-mail addresses in a range and check if the mail address is correct.
Add the code below to the macro and change the To line to this: .To = strto

Dim cell As Range
Dim strto As String
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A1:A10")
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

If you only want to use mail addresses with the word "yes" in the column next to it you can replace

If cell.Value Like "?*@?*.?*" Then
With
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then


Note: I use ThisWorkbook in the examples above to point to the worksheets in the workbook with the code.

 

[arjen van...]

Another method is to use arrays based on column contents. Here's a routine I
put together recently that includes cc (type 2) & Bcc (type 3) in addition to
regular recipients (type 1). You should just need to change some of the
references.


Sub SendEmail()

'create an two dimensional array based on a range for each of
'the To recipients(1), the Cc recipents(2) & the Bcc recipients(3)
Dim MailArray1, MailArray2, MailArray3 As Variant
With Sheets("Sheet1")
MailArray1 = .Range(.Range("AA1"),
..Range("AA1").End(xlDown)).Value
MailArray2 = .Range(.Range("AB1"),
..Range("AB1").End(xlDown)).Value
MailArray3 = .Range(.Range("AC1"),
..Range("AC1").End(xlDown)).Value
End With

'count the upper bound for the first dimension (rows) of each array
Dim x, y, z As Long
x = UBound(MailArray1, 1)
y = UBound(MailArray2, 1)
z = UBound(MailArray3, 1)

'create variables to represent each type of recipient
Dim strMail1, strMail2, strMail3 As String

'create a variable to loop through each array
Dim i As Integer

'if the array
If x < 65000 Then
For i = LBound(MailArray1, 1) To UBound(MailArray1, 1)
strMail1 = strMail1 & CStr(MailArray1(i, 1)) & ";"
Next
ElseIf x > 65000 And Sheets("Sheet1").Range("AA1").Value <> "" Then
strMail1 = CStr(Sheets("Sheet1").Range("AA1").Value)
ElseIf x > 65000 And Sheets("Sheet1").Range("AA1").Value = "" Then
strMail1 = ""
End If

If y < 65000 Then
For i = LBound(MailArray2, 1) To UBound(MailArray2, 1)
strMail2 = strMail2 & CStr(MailArray2(i, 1)) & ";"
Next
ElseIf y > 65000 And Sheets("Sheet1").Range("AB1").Value <> "" Then
strMail2 = CStr(Sheets("Sheet1").Range("AB1").Value)
ElseIf y > 65000 And Sheets("Sheet1").Range("AB1").Value = "" Then
strMail2 = ""
End If

If z < 65000 Then
For i = LBound(MailArray3, 1) To UBound(MailArray3, 1)
strMail3 = strMail3 & CStr(MailArray3(i, 1)) & ";"
Next
ElseIf z > 65000 And Sheets("Sheet1").Range("AC1").Value <> "" Then
strMail3 = CStr(Sheets("Sheet1").Range("AC1").Value)
ElseIf z > 65000 And Sheets("Sheet1").Range("AC1").Value = "" Then
strMail3 = ""
End If


If strMail1 = "" And strMail2 = "" And strMail3 = "" Then
MsgBox Prompt:="No e-mail addresses given.", Title:="Attention!"
Exit Sub
End If

Dim strSubject As String
strSubject = "E-mail addresses from a range - VBA"
Dim strAttachment As String
strAttachment = "K:\Excel\jun09\MailArrayII.xls"
Dim strBody As String
strBody = "This is an example of automating e-mail addresses from "
& vbCrLf & _
"a range. Useful for things you send alot."

Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
Dim olNameSpace As Object
Set olNameSpace = olApp.GetNameSpace("MAPI")
Dim olFolder As Object
Set olFolder = olNameSpace.GetDefaultFolder(6)
Dim olMail As Object
Set olMail = olApp.CreateItem(0)

With olMail
.Subject = strSubject
.Recipients.Add(strMail1).Type = 1
.Recipients.Add(strMail2).Type = 2
.Recipients.Add(strMail3).Type = 3
.Attachments.Add strAttachment
.Body = strBody
.Display
'.Send
End With

End Sub

The only problem I had doing it this way, was if the column contained 0 or 1
e-mail addresses, the upper bound of the first dimension of the array (rows)
woudl be 65,536 (in Excel 2003), hence the extra IF statements to deal with
that.