• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

E mailing list from each sheet to an e mail ID listed in cell A1 of each sheet

Kaushik Joshi

Kaushik Joshi

Member
Hello all,

I have created Pivot Reports that contain an e mail ID in Report Field of each report followed by a List of Data.

I need help to create a macro that will open the workbook, read e mail Address from each report sheet, cut the List of Data ( with formatting intact ), paste it in outlook and e mail it to the e mail address in that sheet.

Attaching sample workbook....with Reports to be used for e mailing.

Tried looking at threads but exact code was not available.
Any help will be much appreciated... even if you can direct to the right resources.
Thank you and good day !

K.Joshi
 

Attachments

Yes, you are right. Whatever size the Pivot table is on each sheet (row, column & value fields only) needs to be cut and e mailed. I have about 150 such Pivot Reports Sheets and each mail should be sent to the e mail ID sitting in the Report field of respective sheet... This needs to work for variable number of sheets and variable numbers of rows on each sheet.
 
Code: 
Option Explicit

Sub EmailRange()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strHtml As String
    Dim SendTo As String
  
    Set rng = Nothing
    On Error Resume Next
  
    SendTo = Worksheets("Email Range").Range("B1").Value
    Set rng = Worksheets("Email Range").Range("A4").CurrentRegion
  
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
        vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
  
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
  
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
  
    'strHtml = "<html>" & "<body>" & "Hi All," & "<br>" & "</br>" & rng & "</body>" & "</html>"
    strHtml = "<p>Please review the latest Department Salary data. " & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Regards," & "<br><br>" & _
                "J. Smith, CFO </p>"
      
    With OutMail
        .to = SendTo
        .CC = ""
        .Subject = "Department Salary Data Update"
        .HTMLBody = strHtml '& RangetoHTML(rng)
        '.Send  'or use .Display
        .Display
    End With
  
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
  
    Set OutMail = Nothing
    Set OutApp = Nothing
  
    Worksheets("Email Range").Range("A1:M50").Value = ""
  
End Sub

Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
  
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  
    'Copy the range and create a new workbook to past the data in
    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 a 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 RangetoHTML
    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 we used in this function
    Kill TempFile
  
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
  
End Function

Sub SummarizeSheets()
Dim ws As Worksheet

For Each ws In Application.Worksheets
    If ws.Name <> "Email Range" And ws.Name <> "Data" And ws.Name <> "Report" Then
        ws.Range("A1:M50").Copy Sheets("Email Range").Range("A1")
        EmailRange
    End If
Next ws

End Sub
 

Attachments

Hey this is working beautifully.
Have 2 questions (no hurry for response....)
a) can I add "cc" e mail address here in the program:
With OutMail
.to = SendTo
.CC = ""

If multiple cc, then hope its ok to separate e mails with a semi-colon or a coma

b) it opens outlook windows with Data in each window and e mail IDs of recipients ready to be fired.
Whats the best way to fire all those e mails at one go, thru macro or thru outlook ?

Thanks a lot !
 
If you are ok with the emails "auto sending" on their own (without first reviewing the email) then in this part of the macro :

Code: 
With OutMail
        .to = SendTo
        .CC = ""
        .Subject = "Department Salary Data Update"
        .HTMLBody = strHtml '& RangetoHTML(rng)
        '.Send  'or use .Display
        .Display
    End With

Edit the lines as :

.Send

'.Display

(NOTE the change of the quote mark). When a quote mark is in front of
a line of code/text in a macro, it tells EXCEL to ignore it. It is only a comment and not code.

After you make the change, the emails will not display - you won't be able to review them first - and they will send automatically.
 
You must log in or register to reply here.
Back
Top