VBA email - MERGE addresses

[C2Code]

Hey, so am a little green when it comes to coding. I found some existing code and tweaked it a bit, but I cannot get the macro to compose ONE email with all the addresses selected into the BCC. Any leads, advice or help?

Instead this macro creates an email for each address selected:


[VBA]Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "G").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing

Application.ScreenUpdating = True
End Sub[/VBA]


Thanks for any help given!

[Bob Phillips]

Selected from where? Should the first email address go to To, the rest to Bcc?

[snb]

[VBA]Private Sub CommandButton1_Click()
with CreateObject("Outlook.Application").CreateItem(0)
.subject="onderwerp"

.to="me@google.com"
.bcc= join(application.transpose(Columns(8).SpecialCells(2)),",")
.Send
End With
End Sub[/VBA]

[GTO]

...I cannot get the macro to compose ONE email with all the addresses selected into the BCC....

Greetings C2Code,

Just a "practice throw" if you will, but in essence, I think you will want to build the string of addresses in your loop, then just create one message.

[vba]Option Explicit

Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strAddresses As String

On Error GoTo cleanup
For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "G").Value) = "yes" Then

strAddresses = strAddresses & cell.Text & "; "

End If
Next cell

strAddresses = Trim(strAddresses)


If Len(strAddresses) > 0 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = strAddresses
.Display
End With
Else
Exit Sub
End If

cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
[/vba]

Does that help?

Mark

EDIT: Okay, a mis-throw.... here's a "do over"