Send email macro to multiple recipients

L

laurainwa

New Member
Joined
Dec 23, 2011
Messages
7
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
 
Sort by date Sort by votes
Siyanna said:
Thank You
Click to expand...

Siyanna said:
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.
Click to expand...

Hi Andrew poulsom, pgc01, vog, alphFrog, jonmo1...

Any one you gurus. Can anyone you guys please help me with the above. I know it will be like a piece of cake for you guys. Thank you
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Siyanna said:
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

Code: 
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
Click to expand...
Thank you
 
Upvote 0
Try:

Code: 
Sub Send_Email()
    Dim ws As Worksheet
    Dim ans As VbMsgBoxResult
    Dim i As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim Mail_Object
    Dim o As Variant
    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
        TempFilePath = Environ$("temp") & "\"
        TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
        FileExtStr = ".xlsm"
        ActiveWorkbook.SaveCopyAs TempFilePath & TempFileName & FileExtStr
        Set wb = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
        With wb.Worksheets(ws.Range("O" & i).Value).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        Application.DisplayAlerts = False
        For Each sh In wb.Worksheets
            If sh.Name <> ws.Range("O" & i).Value Then
                sh.Delete
            End If
        Next sh
        Application.DisplayAlerts = False
        wb.Save
        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 wb.FullName
            .Send 'Will send straight away use .display to send manually
        End With
        wb.Close SaveChanges:=False
        Kill TempFilePath & TempFileName & FileExtStr
        Set Mail_Object = Nothing
    Next i
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Upvote 0
Andrew Poulsom said:
Try:

Code: 
Sub Send_Email()
    Dim ws As Worksheet
    Dim ans As VbMsgBoxResult
    Dim i As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim Mail_Object
    Dim o As Variant
    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
        TempFilePath = Environ$("temp") & "\"
        TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
        FileExtStr = ".xlsm"
        ActiveWorkbook.SaveCopyAs TempFilePath & TempFileName & FileExtStr
        Set wb = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
        With wb.Worksheets(ws.Range("O" & i).Value).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        Application.DisplayAlerts = False
        For Each sh In wb.Worksheets
            If sh.Name <> ws.Range("O" & i).Value Then
                sh.Delete
            End If
        Next sh
        Application.DisplayAlerts = False
        wb.Save
        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 wb.FullName
            .Send 'Will send straight away use .display to send manually
        End With
        wb.Close SaveChanges:=False
        Kill TempFilePath & TempFileName & FileExtStr
        Set Mail_Object = Nothing
    Next i
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Click to expand...


Hi Andrew, i will try the above code at work and will let you know if it works ( i am sure it will). Thank you and everyone who has helped.

P.s

I can see you have taken out a couple of steps

FileFormatNum = 52
Set OutApp = Nothing

Don't i need those 2 lines?

And what is the difference between

With Worksheets(ws.Range("O" & i).Value).UsedRange
and without the used range With Worksheets(ws.Range("O" & i).Value)?

Thank You Sir
 
Upvote 0
A copy of the workbook is saved in its existing format using SaveCopyAs so there is no need for the FileFormatNum variable. You hadn't used the variable OutApp previously in your code so setting it to Nothing was unnecessary. I set Mail_Object to Nothing.

The UsedRange represents all the used cells on the worksheet (a rectangular range). It can't be omitted because you want to copy it.
 
Upvote 0
Andrew Poulsom said:
A copy of the workbook is saved in its existing format using SaveCopyAs so there is no need for the FileFormatNum variable. You hadn't used the variable OutApp previously in your code so setting it to Nothing was unnecessary. I set Mail_Object to Nothing.

The UsedRange represents all the used cells on the worksheet (a rectangular range). It can't be omitted because you want to copy it.
Click to expand...


Total LEGEND....
 
Upvote 0
Hi Guys...

How do i change the highlighted part in red.

Each day i run the code it will be for the previous day. This part
Format(Now, "dd-mmm-yy") will save it as todays date. What i need is to have yesterdays date. So if i ran it today then have yesterday's date
Now - 1. However If i run it on a Monday say (16/01/2012) then the date saved should be the previous Fridays date (13/01/2012).


TempFilePath = Environ$("temp") & "\"
TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
 FileExtStr = ".xlsm"
ActiveWorkbook.SaveCopyAs TempFilePath & TempFileName & FileExtStr
 
Upvote 0
Siyanna said:
Hi Guys...

How do i change the highlighted part in red.

Each day i run the code it will be for the previous day. This part
Format(Now, "dd-mmm-yy") will save it as todays date. What i need is to have yesterdays date. So if i ran it today then have yesterday's date
Now - 1. However If i run it on a Monday say (16/01/2012) then the date saved should be the previous Fridays date (13/01/2012).


TempFilePath = Environ$("temp") & "\"
TempFileName = ws.Range("O" & i).Value & " " & Format(Now, "dd-mmm-yy")
 FileExtStr = ".xlsm"
ActiveWorkbook.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Click to expand...

Bump
 
Upvote 0
You must log in or register to reply here.

Similar threads

catscantuseexcel
  • Solved
VBA to send sheets based on column values
Replies
3
Views
700
DanteAmor
DanteAmor
M
  • Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
267
mecerrato
M
H
  • Question
Macro to attached sheets without formulas
Replies
2
Views
432
howard
H
T
  • Solved
How to email a range in Excel
Replies
5
Views
871
kevin9999
K
R
  • Question
VBA copy spredsheet contain pivot table as value
Replies
0
Views
374
Rafi_co
R

Forum statistics

Threads
1,216,119
Messages
6,128,947
Members
449,480
Latest member
yesitisasport

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top