Sending to Multiple Email Addresses From Cells

[Aspen]

I am created a Excel file in Office 2007 which consists list of email address in each of it's cell, now i am planning to create VBA code where i can send all an email to all the person which are listed in my Excel file. For more information i am using MS Outlook as my default email and i had asked my friends about the same they don't have any idea about it.

[Ramchandra]

If you want to send Multiple Email Addresses From Cells using VBA code then i would suggest you to copy paste the below code i am sure this will help you a lot.

Sub TestFile()
    Dim OutApp1 As Object
    Dim Out_Mail As Object
    Dim cell1 As Range

    Application.ScreenUpdating = False
    Set OutApp1 = CreateObject("Outlook.Application")

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

            Set Out_Mail = OutApp1.CreateItem(0)
            On Error Resume Next
            With Out_Mail
                .To = cell1.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell1.Row, "A").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .Send  'Or use Display
            End With
            On Error GoTo 0
            Set Out_Mail = Nothing
        End If
    Next cell1

cleanup:
    Set OutApp1 = Nothing
    Application.ScreenUpdating = True
End Sub

[Aspen]

Thanks for replying me i had try to use the above code which you had given me but it's not working, when i am trying to send an email i am not able to do so, can anyone tell me or make some changes in the code by which i can send an email to the contact which i had added in my excel file.

[Bassus]

In the above code i would suggest you to add the below code to the sub before loop gets start

Dim str_body As String
    For Each cell In Range("E1:E20")
        str_body = str_body & cell.Value & vbNewLine
    Next

at the same time also replace the body line with this one

.Body = "Display " & Cells(cell.Row, "A").Value & vbNewLine & vbNewLine & strbody

[Amelia]

Don't worry my friend there is no need to use any of the codes which are mention above i had made changes in the code where you need to directly copy paste the code and your problem is over

Sub EmailGroup()

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

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strto1
.Subject = "Enter subject here"
.Body = "" ' EMPTY FOR NOW
'USE THIS FOR ENTERING NAMES OF RECIPIENTS IN BODY TEXT "here"
'"Dear" & Cells(cell1.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Enter body text " & _
"here"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'Or use Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub