Send email macro to multiple recipients

[laurainwa]

I'm using the macro listed below (from RondeBruin) to send a worksheet as an attachment. It works great, except I am sending it to multiple recipients and I have to click the "allow" program to send email for each and every email. Is there a way to just send one email to everyone I need? I need to know what part of this code to delete and what to replace it with. (I don't know really anything about VBA code so I need it in as simple terms as possible. )
Sub Mail_ActiveSheet()
'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim I As Long

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-2010, 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
For I = 1 To 3
.SendMail "ron@debruin.nl", _
"This is the Subject line"
If Err.Number = 0 Then Exit For
Next I
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

 

[VoG]

I have not read through this thread in detail but see if this helps regarding copying a module from one workbook to another http://www.cpearson.com/excel/VBE.aspx

 

[Siyanna]

I have not read through this thread in detail but see if this helps regarding copying a module from one workbook to another http://www.cpearson.com/excel/VBE.aspx

Not sure how I can amend to copy this in to my code. Andrew Poulsen has come within idea to copy the same workbook again but instead delete all the sheets exept the one in my loop so that way I keep the macro but I don't how to do that. Hopefully Andrew or anyone else can look at this for us.

Again I would also like to thank Michael m for all his help.

 

[Siyanna]

Not sure how I can amend to copy this in to my code. Andrew Poulsen has come within idea to copy the same workbook again but instead delete all the sheets exept the one in my loop so that way I keep the macro but I don't how to do that. Hopefully Andrew or anyone else can look at this for us.

Again I would also like to thank Michael m for all his help.

Thank you

 

[laurainwa]

Thank you all very much for your help! It worked!!

 

[Michael M]

Hmm, so you were the original poster and the last poster, but nothing in between...are you one and the same person ??

 

[laurainwa]

Yes - same person. I was off work through the weekend and did not check the forums until I came back today. Thank you again for your help!

 

[Siyanna]

Hi Andrew,Vog. MVP's....


I have tested the below code at work and this works fab...If you could help me add the bit of code so that i can also copy Module 2 over to the new sheet, that would be fabulous. This bit will help me alot and will save me alot of time. Again thank you all for your help

Thank You

Sub Send_Email()
Dim Email_Subject, Email_Send_From, Email_Body As String, i As Integer
Dim Mail_Object, nameList As String, o As Variant, ws As Worksheet, ws1 As Worksheet
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
Set ws = Worksheets("INDEX SHEET") 'Sheet name of recipient list
    ans = MsgBox("Are you sure you want to send email's to all individuals in list ??", vbYesNo)
        If ans = vbNo Then Exit Sub
For i = 4 To 5
    Worksheets(ws.Range("O" & i).Value).Copy
        With Worksheets(ws.Range("O" & i).Value).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Range("A1").Select
        End With
        Application.CutCopyMode = False
    TempFilePath = Environ$("temp") & "\"
    TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
    FileExtStr = ".xlsm"
    FileFormatNum = 52
        With ActiveWorkbook
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        End With
        Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = "Your Latest Worksheet "
            .To = ws.Range("P" & i).Value
            .Body = "MESSAGE TEXT HERE"
            .Attachments.Add ActiveWorkbook.FullName
            .Send 'Will send straight away use .display to send manually
        End With
        With ActiveWorkbook
            .Close SaveChanges:=False
        End With
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
Next i
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Siyanna]

Hi Andrew,Vog. MVP's....


I have tested the below code at work and this works fab...If you could help me add the bit of code so that i can also copy Module 2 over to the new sheet, that would be fabulous. This bit will help me alot and will save me alot of time. Again thank you all for your help

Thank You

Sub Send_Email()
Dim Email_Subject, Email_Send_From, Email_Body As String, i As Integer
Dim Mail_Object, nameList As String, o As Variant, ws As Worksheet, ws1 As Worksheet
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
Set ws = Worksheets("INDEX SHEET") 'Sheet name of recipient list
    ans = MsgBox("Are you sure you want to send email's to all individuals in list ??", vbYesNo)
        If ans = vbNo Then Exit Sub
For i = 4 To 5
    Worksheets(ws.Range("O" & i).Value).Copy
        With Worksheets(ws.Range("O" & i).Value).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Range("A1").Select
        End With
        Application.CutCopyMode = False
    TempFilePath = Environ$("temp") & "\"
    TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
    FileExtStr = ".xlsm"
    FileFormatNum = 52
        With ActiveWorkbook
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        End With
        Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = "Your Latest Worksheet "
            .To = ws.Range("P" & i).Value
            .Body = "MESSAGE TEXT HERE"
            .Attachments.Add ActiveWorkbook.FullName
            .Send 'Will send straight away use .display to send manually
        End With
        With ActiveWorkbook
            .Close SaveChanges:=False
        End With
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
Next i
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Thank You

 

[Michael M]

Before going down the copy module path, have you considering a couple of other options.
A suggestion from Andrew Polsom, even though he hasn't had any input in this thread, regarding sending the entire workbook, with ALL unwanted sheets deleted OR sending the entire workbook with all unwanted sheets VeryHidden ?
It appears you are only sending the sheets / workbook to 2 other users !

For i = 4 To 5

 

[Siyanna]

Hi Michael,

I was hoping Andrew could have helped me how to go about adding a workbook and deleted all unwanted sheets Execept for the one in the loop one by one. The loop will be expanding. I only tested on 2 email addresses. I have no clue how to go about Andrews suggestion.

Thanks to you I have learned how you put the email macro together.
Thank you. If anyone or Andrew or you can help me with adding to the code to help me with this macro query that would be a life savour. I cant thank you enough.