Macro to send email with sepecific range of cells to a specific group of email ID

[Latha]

Hi team,

I need help in writing macro. I have an excel file with some 180 records (of incident ageing report) with the below column headers.

Group Name - column A
Organization - column B
Manager / TL Responsible - column C
0 - 2 days old - - column D (these values are the count of incidents ageing 0-2 days)
3 - 5 days old - column E
6 - 8 days old - column F
9 - 10 days old - column G
Greater Than 10 Days - column H

what I need is a macro which picks the manager name from column C and creates an outlook email with the data (cell range from D2:H2) exists against his name.

Please help. this is really very urgent requirement.

 

[ranman256]

this may work, it collects all the managers in your list, then filters all the data for each manager
then emails it, by storing the report in a temporary file, vRpt2Send = "C:\Temp\Report.pdf"

'-------------
Sub FilterThenEmail()
'-------------
Dim colMgr As New Collection
Dim lRows As Long
Dim mgr
Dim vRpt2Send
Dim shtTarg As Worksheet, shtSrc As Worksheet
Dim vEmail, vSubj, vBody


On Error Resume Next


vRpt2Send = "C:\Temp\Report.pdf"   'send this report
vSubj = "manager report"
vBody = "manager report " & Date


Range("A1").Select
lRows = ActiveSheet.UsedRange.Rows.Count


    'collect all managers  (no dupes)
Range("B2").Select
While (ActiveCell.Value) <> ""
   If ActiveCell.Value <> "" Then colMgr.Add ActiveCell.Value
   ActiveCell.Offset(1, 0).Select    'next row
Wend


Set shtSrc = ActiveSheet
If ActiveSheet.AutoFilterMode = False Then Selection.AutoFilter
Sheets.Add
Set shtTarg = ActiveSheet


    'now filter the data for every manager
For Each mgr In colMgr
    shtSrc.Activate
    vEmail = ActiveCell.Offset(0, 1).Value      'get manager email here
    
    ActiveSheet.Range("$A$1:$J$" & lRows).AutoFilter Field:=2, Criteria1:=mgr
    Range("A1:J" & lRows).Select
    'Range("B1").Activate
    Selection.Copy
    
    shtTarg.Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        vRpt2Send, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False


    Email1 vEmail, vSubj, vBody, vRpt2Send
    
      'clear the data
    Cells.Select
    Selection.ClearContents
    Range("a1").Select
Next


   'cleanup
Set shtSrc = Nothing
Set shtTarg = Nothing
sest colMgr = Nothing
End Sub


'-------------
Public sub Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
'-------------
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem


On Error GoTo ErrMail


    'NOTE  BE SURE YOU ADD OUTLOOK APP VIA  VBE menu:TOOLS, REFERENCES


Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)


With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody
    
    If Not IsEmpty(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    .Send
End With


'Email1 = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function


ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume Next
End sub

 

[Latha]

hi Ranman256,

Thanks for the reply.
but unfortunately, as I m new to VBA/macro I couldn't execute the above codes.

but somehow I could consolidate some pieces of codes from google and modified it to match my requirement. Please find the below code

Sub sendmail()
Dim olapp As Outlook.Application
Dim olmail As Outlook.MailItem

For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
Set olapp = New Outlook.Application
Set olmail = olapp.CreateItem(olMailItem)

With olmail
.To = Cells(i, 1).Value
.CC = Cells(i, 2).Value
.Subject = Cells(i, 3).Value
.Body = Range(Cells(i, 4), Cells(i, 9)).Value
.Display
ThisWorkbook.Save
.Attachments.Add "C:\Users\dlatha\Desktop\OpenTickets_OCN-ASPS_Aug25.xlsm"
''.send
End With

Set olmail = Nothing
Set olapp = Nothing
Next

End Sub

The above code does the task of creating an email, attaching the file, and updating To and Cc fields. My only problem is at the line ".Body = Range(Cells(i, 4), Cells(i, 9)).Value"

In this line, I would like the excel to copy paste the range from D2 to H2 in the mail body.

Please help.

Please note: I have modified my headers to match my requirement and now my file is looks completely different from my old file I have explained in my first post on this thread.

now my file shows as below :

Column A - To email IDs
Column B - CC email IDs
Column C - Group name
Column D to H : Data to be copied to the mail body

Please help and please excuse me if im confusing you.

 

[Latha]

Hello, Could anyone respond to my query please... Please... Please...

I pray you please... ray:

 

[daverunt]

Hi,

You are almost there. See RangeToHTML example from Ron.

Mail Range/Selection in the body of the mail

So you need to; Set Rng=<your range>
(place before with olmail)

Use .HTMLBody = RangetoHTML(rng) instead of .Body=

And paste the complete function
Function RangetoHTML(rng As Range)

after your End Sub.

You can use .Body and concatenate the cells and columns but I would only do that for a small range.

 

[Latha]

Thanks dear. ray: ray: it worked. But I have to make the range as dynamic range. for example: for the email ID in A4 cell.. excel should insert the data only from D4 to I4 and then it should add the specific headers from D1:I1
likewise for email ID in A5 cell.. it should insert data only from D5:I5 and then it should add the specific headers from D1:I1

Below is the code how it looks now. kindly modify this to include my requirement as stated above and send it to me Pleasee Pleaseee

Sub sendmail()
Dim olapp As Outlook.Application
Dim olmail As Outlook.MailItem
Dim rng As Range

For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
Set olapp = New Outlook.Application
Set rng = Sheets("AspsByGroup").Range("D2:I2").SpecialCells(xlCellTypeVisible)
Set olmail = olapp.CreateItem(olMailItem)

With olmail
.To = Cells(i, 1).Value
.CC = Cells(i, 2).Value
.Subject = Cells(i, 3).Value
'Set body format to HTML
.HTMLBody = RangetoHTML(rng)
ThisWorkbook.Save
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.Display
''.send
End With

Set olmail = Nothing
Set olapp = Nothing
Next

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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 xublishsource=", _
"align=left xublishsource=")

'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

 

[daverunt]

I'm at work and don't have time to look at this but here's a couple of pointers.

You need to set a range for the headers

Set HdrRng = Range("D1:I1")

determine the start row of the range for each mail.
I think the following should do it.

Set Rng = Sheets("AspsByGroup").Range("D" & i & ":" & "I" & i)

Add both ranges to the email.

.HTMLBody = RangetoHTML(HdrRng) & RangetoHTML(Rng)

 

[Latha]

Thanks. but this is leaving a space in between the headers and the Range("D" & i & ":" & "I" & i)

I want them look like a single table. Please help.

 

[daverunt]

Hi,

Excel generates a space between the 2 HTML tables. I did get around this before....
I'll get back to you shortly.

 

[daverunt]

Hi,

found it..

You have to join the 2 ranges using Union before using RangeToHTML.

Set rngFinal = Union(HdrRng, Rng)


Outlook......
.HTMLBody = RangetoHTML(rngFinal)