Loop through Email address

  • Hi,
    Below is some code I put together to send email from excel.

    Basically this is tied to a command button that is embedded on a worksheet named , Email

    The workbook has only one worksheet named, Email. Then three range names.
    Addresses, A2:A2500 . Subject, B2. And Body, C2.

    Notice the use of these range names in the code .

    What this macro does is load all the address into an array using the semi colon as a separator. Then read all the address into the .To command.

    Well, I think I have way to many addresses for this to work. I need help in modifying the code to loop through the addresses and sending email with an attachement.

    This way I hope not to overwhelm outlook with address all at once.

    Any ideas on how to moidfy my code would greatly be apprecitated.

    Thanks in advance,

    Private Sub CommandButton1_Click()

    Dim objOL As New Outlook.Application
    Dim objMail As MailItem

    Set objOL = New Outlook.Application
    Set objMail = objOL.CreateItem(olMailItem)

    Dim AddressRange, Arange As Range
    Dim Addresses, Adrs As String
    Dim Subject, Sbj As String
    Dim Message, Bdy As String
    Dim i As Integer

    Sbj = Worksheets("Email").Range("Subject")
    Bdy = Worksheets("Email").Range("Body")
    Set Arange = Worksheets("Email").Range("Addresses")

    Address = " "
    If Arange.Rows.Count = 1 Then
    Addresses = Arange.Rows(1).Value
    For i = 2 To Arange.Rows.Count
    Addresses = Arange.Rows(1).Value
    Addresses = Addresses & Chr(59) & Arange(i).Value
    i = i + 1
    Next i
    Adrs = Addresses

    End If

    With objMail
    .To = Adrs
    .Subject = Sbj
    .Body = Bdy
    End With
    Set objMail = Nothing
    Set objOL = Nothing

    MsgBox "Mail Sent"

  • Hi David,

    Following procedure shows how You can add an attachment and add several recipients.

    To get it to work properly a reference to MS Outlook x.x Library must be set via the Tool | Reference... in the VB-editor.

    Option Explicit

    Sub Send_Worksheet_Outlook()
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim rnRecipients As Range
    Dim vaRecipients As Variant
    Dim i As Long
    Dim olApp As Outlook.Application
    Dim olNewMail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set olNewMail = CreateItem(olMailItem)

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Sheet1")
    With wsSheet
    Set rnRecipients = .Range("Addresses")
    End With

    vaRecipients = rnRecipients.Value

    With olNewMail
    For i = LBound(vaRecipients) To UBound(vaRecipients)
    .Recipients.Add (vaRecipients(i, 1) & ";")
    Next i
    .CC = "Team 2000"
    .BCC = "Evaluering"
    .Subject = "Subject: Programlist"
    .Body = "As per agreement."
    With .Attachments
    .Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
    .Item(1).DisplayName = "Sendmail"
    End With
    End With

    Set olNewMail = Nothing
    Set olApp = Nothing

    End Sub

    Outlook can handle many recipients (upto 32 k) but the bottle neck might be the ISP so please check with them.

    Special Note: If You don´t want to view all the recipients to all the recipients use BCC and set Your own e-mailaddress to TO :guitar: