Auto E-Mail to preselected list.

[Jogier505]

This is for a mailing of the standings for the NCAA tournament. I have done a search and found the following link,

. and have applied this to my sheet but I am at a loss as to how to pick up each address from column "D" on the E-Mail sheet.

Thanks

JIm O

[JBeaucaire]

Further in that site is this page, which shows how to cycle through a column and test for the @ symbol to determine if an email address is there...

http://www.rondebruin.nl/mail/folder1/mail5.htm

[Jogier505]

With my very limited knowledge of VBA I am missing something. I have applied the code to module 1 in the workbook but I am not sure where to refference the sheet "E-Mail".

Sub Mail_ActiveSheet()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "ron@debruin.nl", _
                  "Current Standings"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Sub Mail_Every_Worksheet()
'Working in 97-2007
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    For Each sh In ThisWorkbook.Worksheets
        If sh.Range("D1").Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = "Sheet " & sh.Name & " of " _
                         & ThisWorkbook.Name & " " _
                         & Format(Now, "dd-mmm-yy h-mm-ss")

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, _
                        FileFormat:=FileFormatNum
                On Error Resume Next
                .SendMail sh.Range("D1").Value, _
                          "This is the Subject line"
                On Error GoTo 0
                .Close SaveChanges:=False
            End With

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Thanks

Jim O

[Leith Ross]

Hello Jim,

Here is a simplified version of the macro. This macro has been added to the attached workbook and to the button on the "Standings" worksheet.

'Written: March 13, 2010
'Author:  Leith Ross
'Summary: Emails the Standings worksheet as a workbook to all email addresses on the
'         E-Mail worksheet in column "D".

Sub EmailMacro()

  Dim Addresses() As Variant
  Dim EmailWks As Worksheet
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Subj As String
  Dim TempPath As String
  Dim TempWkb As Workbook
  Dim Wks As Worksheet
    
    Subj = "This is the email subject line."
    
    Set Wks = Worksheets("Standings")
    Set EmailWks = Worksheets("E-Mail")
    
    Set Rng = EmailWks.Range("D2")
    Set RngEnd = EmailWks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, EmailWks.Range(Rng, RngEnd))
    
      ReDim Addresses(0 To Rng.Rows.Count - 1)
    
      For I = 1 To Rng.Rows.Count
        Addresses(I - 1) = Rng(I)
      Next I
      
        Set TempWkb = Workbooks.Add(Template:=xlWBATWorksheet)
        TempWkb.Sheets(1).Name = "NCAA Standings"
        TempPath = Environ("temp") & "\" & "NCAA Standings.xls"
        If Dir(TempPath) <> "" Then Kill TempPath
        
        TempWkb.SaveAs TempPath
        Wks.UsedRange.Copy
        TempWkb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
        
      TempWkb.SendMail Addresses, Subj
      TempWkb.Close SaveChanges:=True
    
End Sub

[JBeaucaire]

Leith, great stuff. I need to spend more time with the SendMail stuff.

One thought, you should be able to fill your Addresses array directly without looping or even redimming.:

      ReDim Addresses(0 To Rng.Rows.Count - 1)
    
      For I = 1 To Rng.Rows.Count
        Addresses(I - 1) = Rng(I)
      Next I

becomes...

Addresses = Application.WorksheetFunction.Transpose(Rng.Value2)

The "I" variable needed to be declared, but in this situation you won't need it at all.

One other thought, you might be able to fill in the RNG all in one step as well, with:

Set Rng = EmailWks.Range("D2:D" & Rows.Count).SpecialCells(xlCellTypeConstants)

What do you think? We may only be talking milliseconds, but what the hey!

My two cents...

[Leith Ross]

Hello Jerry,

Thanks for the input. Let me explain the logic behind my decisions. VBA will generally and automatically adjust a standard Array, zero based, to a Range which is one based and always 2-D and vice versa. I chose to use the loop to ensure the string Array required by the SendMail function is a always a zero based array. SendMail function invokes the default email client and may not convert the 1 based array correctly to a zero based array. The macro would then miss the first email address in the list. If there is only email being sent and there is no address then the email client will throw an error.

The code structure I use for setting the Rng object variable will not error if the cells are empty. It simply defaults to the first cell in the range. The SpecialCells property will. Also, you can not check this property first to verify there are no empty cells. You have to trap the error using an On Error Resume or On Error Goto statement. Personally, I like to avoid runtime errors whenever possible.

[Jogier505]

I am still having problems getting the code to work. I keep getting a run time error 1004.
When I click the send button on the sheet the temp file is created and a screen comes up with the subject line but no addresses. If I click the send button on the new screen I am asked weather I want to end or debug. See attached file.


Thanks, Jim O

[Jogier505]

Bump.

Any thoughts?


Jim O

[Leith Ross]

Hello Jim,

Try using valid email addresses on the email sheet. Here is the error I got when I ran the code. Look familiar?

Run-time error '1004'

Unknown recipient found in the recipient list. Use a valid name and try again.