Results 1 to 5 of 5

Sending an email from Excel to multiple email addresses

Threaded View

  1. #1
    Registered User
    Join Date
    12-28-2006
    Posts
    97

    Sending an email from Excel to multiple email addresses

    I am using the following code and it works great the only problem is that when I have more then one email address in the same cell it will not send the email. Even if I seperate it with a semicolon. It work fine if I have just one email address in the email field. How can I get it to send the same info to different email addresses.

    Sub Email2()
    
        Dim rng As Range
        Dim Ash As Worksheet
        Dim Cws As Worksheet
        Dim Rcount As Long
        Dim Rnum As Long
        Dim FilterRange As Range
        Dim FieldNum As Integer
        Dim NewWB As Workbook
        Dim TempFilePath As String
        Dim TempFileName As String
        Dim FileExtStr As String
        Dim FileFormatNum As Long
    
        On Error GoTo cleanup
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        'Set filter sheet, you can also use Sheets("MySheet")
        Set Ash = ActiveSheet
    
        'Set filter range and filter column (column with e-mail addresses)
        Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
        FieldNum = 2    'Filter column = B because the filter range start in column A
    
        'Add a worksheet for the unique list and copy the unique list in A1
        Set Cws = Worksheets.Add
        FilterRange.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=Cws.Range("A1"), _
                CriteriaRange:="", Unique:=True
    
        'Count of the unique values + the header cell
        Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
    
        'If there are unique values start the loop
        If Rcount >= 2 Then
            For Rnum = 2 To Rcount
    
                'If the unique value is a mail addres create a mail
                If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
    
                    'Filter the FilterRange on the FieldNum column
                    FilterRange.AutoFilter Field:=FieldNum, _
                                           Criteria1:=Cws.Cells(Rnum, 1).Value
                                        
                    'Copy the visible data in a new workbook
                    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With
    
                    Set NewWB = Workbooks.Add(xlWBATWorksheet)
    
                    rng.Copy
                    With NewWB.Sheets(1)
                        .Cells(1).PasteSpecial Paste:=8
                        .Cells(1).PasteSpecial Paste:=xlPasteValues
                        .Cells(1).PasteSpecial Paste:=xlPasteFormats
                        .Cells(1).Select
                        Application.CutCopyMode = False
                    End With
    
                    'Create a file name
                    TempFilePath = Environ$("temp") & "\"
                    TempFileName = "BOD " & Format(Now, "dd-mmm-yy h-mm-ss")
    
                    If Val(Application.Version) < 12 Then
                        'You use Excel 2000-2003
                        FileExtStr = ".xls": FileFormatNum = -4143
                    Else
                        'You use Excel 2007
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
    
                    'Save, Mail, Close and Delete the file
                    With NewWB
                        .SaveAs TempFilePath & TempFileName _
                              & FileExtStr, FileFormat:=FileFormatNum
                        On Error Resume Next
                        .SendMail Cws.Cells(Rnum, 1).Value, _
                                  "BOD Appointment Reminder"
                        On Error GoTo 0
                        .Close savechanges:=False
                    End With
    
                    Kill TempFilePath & TempFileName & FileExtStr
                End If
    
    
                'Close AutoFilter
                Ash.AutoFilterMode = False
    
            Next Rnum
        End If
    
    cleanup:
        Application.DisplayAlerts = False
        Cws.Delete
        Application.DisplayAlerts = True
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub
    Last edited by insanity66; 10-14-2009 at 02:02 PM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1