Solved

Macro to email a selected range to list of recipients from excel 2010

Posted on 2013-01-06
5
573 Views
Last Modified: 2013-01-30
I want to create a macro that would select a range in the spreadsheet and then email it to a recepient or recepients thru Outlook, and then close the Outlook and return to the spread sheet.
0
Comment
Question by:hpjethwa
5 Comments
 
LVL 17

Expert Comment

by:Kent Dyer
ID: 38749836
Something like this?

http://www.cpearson.com/excel/Email.aspx

HTH,

Kent
0
 
LVL 16

Expert Comment

by:theo kouwenhoven
ID: 38750346
You even can do it without Outlook,
Create the mail in a file and use a Telnet session to send.
0
 
LVL 9

Accepted Solution

by:
TazDevil1674 earned 500 total points
ID: 38750427
Try the code below.  I have the code in a Module and have assigned the macro to a button on the sheet...

I also have a Recipients sheet, where I can specify the person(s) for the TO:, CC: and Send on Behalf of fields as required

Sub SendEmail()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngToEmail As Range, rngToCell As Range, strToEmail As String
Dim rngCCEmail As Range, rngCCCell As Range, strCCEmail As String
Dim Rng As Range
Dim ButtonChosen As Integer

ButtonChosen = MsgBox("Do you want to send Rota as " & Sheets("Recipients").Range("E2") & "?", vbQuestion + vbYesNo + vbDefaultButton2, "Continue?")

Set Rng = Nothing
On Error Resume Next
'Select Correct Sheet Name and Range
Set Rng = Sheets("Sheet to Email Name").Range("A1:J19") '.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

'set sheet to find address for e-mails as I have several people to mail to
'TO Field
Set rngToEmail = Sheets("Recipients").Range("A2:A51")
For Each rngToCell In rngToEmail.Cells
strToEmail = strToEmail & ";" & rngToCell.Value
Next
'CC Field
Set rngCCEmail = Sheets("Recipients").Range("C2:C51")
For Each rngCCCell In rngCCEmail.Cells
strCCEmail = strCCEmail & ";" & rngCCCell.Value
Next

With aEmail
    'set Importance
    .Importance = 2
    'Set Subject
    .Subject = Emailed Sheet and HTML
    'Set Body for mail
    .HTMLBody = "<p style='font-family:calibri;font-size:14'>" & _
        "Please see below for the HTML Version of my select cells from Excel." & _
        "</p><BR>" & _
        RangetoHTML(Rng)
    'Set attachment - un comment this if you want the whole spreadhseet attached too
    '.Attachments.Add ActiveWorkbook.FullName
    'Set Recipient
    .To = strToEmail
    .CC = strCCEmail
    'or send one off to 1 person use this static code
    '.Recipients.Add "E-mail.address-here@ntlworld.com"
    'send on behalf of
    If ButtonChosen = vbYes Then
        .SentOnBehalfOfName = Sheets("Recipients").Range("E2")
    Else
    End If
    'Send Mail
    .Display
    '.Send
End With

End Sub

Function RangetoHTML(Rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Open in new window

0
 
LVL 59

Expert Comment

by:LeeTutor
ID: 38838390
I've requested that this question be deleted for the following reason:

Not enough information to confirm an answer.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now