Send Email Based on Spreadsheet Criteria

[WDP]

I have a spreadsheet with data that looks something like the data below. I
am looking for a way to automate sending an email to each user (Email Field)
with all the rows that include data for that User

Date Email Subject
6/27/2005 (e-mail address removed) Test4
6/27/2005 (e-mail address removed) Test7
6/28/2005 (e-mail address removed) Test3
6/28/2005 (e-mail address removed) Test6
6/29/2005 (e-mail address removed) Test1
6/29/2005 (e-mail address removed) Test2
6/29/2005 (e-mail address removed) Test5

For (e-mail address removed) would get an email with the following
information

Date Email Subject
6/29/2005 (e-mail address removed) Test1
6/29/2005 (e-mail address removed) Test2
6/28/2005 (e-mail address removed) Test3
6/27/2005 (e-mail address removed) Test4

Any ideas on whether Excel can even do this....and if so, how one would go
about making it happen.

Thank you

 

[Ron de Bruin]

Hi

Attachment or Body ?
Which mail program do you use

 

[Ron de Bruin]

Hi WDP

Bed time for me now but here is small example for you to try

This is a example for Outlook
Copy it all in a normal module

Change this to your sheet
Set ws1 = Sheets("Sheet1")

Change this to your range (Use headers in the first row)
Set rng = ws1.Range("A1:C100")
The macro filter on the second column(B)

'*********************************

Option Explicit

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Public Sub Test_With_AdvancedFilter()

Application.ScreenUpdating = False

Set ws1 = Sheets("Sheet1")
Set ws2 = Worksheets.Add
Set rng = ws1.Range("A1:C100")
'Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the second column (B) in the range (change this if needed)

With ws1
rng.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

ws2.Cells.ClearContents
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=ws2.Range("A1"), _
Unique:=False

.Columns.AutoFit

' Run the mail macro
Mail_ActiveSheet_Body

Next
.Columns("IU:IV").Clear
End With
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
End Sub


Private Sub Mail_ActiveSheet_Body()
Dim OutApp As Object
Dim OutMail As Object
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ws2.Range("B2").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = SheetToHTML(ws2)
.display 'or use .Send
End With
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Public Function SheetToHTML(sh As Worksheet)
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function

'***********************************

 

[WDP]

Sorry about that.....Yes....Outlook.....An attachment would be
prefered....but if the data was within the body of the email....that would
work as well.

 

[Ron de Bruin]

Try the example I posted

 

[Angus]

I amend your code as following, to send the pivot chart with name "chart",
but it doesn't work, why?

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim ws As Worksheet
Dim msg As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each ws In ThisWorkbook.Worksheets
If InStr(ws.Name, "chart") > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = ws.Name
.HTMLBody = SheetToHTML(ws)
.Send 'or use .Display
End With
Set OutMail = Nothing
End If
Next ws

 

[Ron de Bruin]

Hi Angus

A chart sheet is not a worksheet
We loop trough the worksheets in the example

For Each ws In ThisWorkbook.Worksheets

You can do this

For Each ws In ThisWorkbook.Sheets

But the SheetToHTML is not working with charts and pictures

If you want to send a chart then look at this example
http://www.rondebruin.nl/mail/folder2/chart.htm

 

[Angus]

My problem is i have a lot of pivot charts to send, so I cannot give a chart
name to export gif. How to amend the code?

 

[pf]

lets say i have price quote sheet on my screen- i want to draw lines and
maybe squares on it - then email and maybe save