Mail a row or rows to each person in a range with SendMail
Important read this :
The code on this page is working with Outlook, Outlook Express and Windows Mail.
With SendMail it is not possible to :
1) Send text in the Body of the mail
2) Use the CC or BCC field
3) Attach other files
If you want to have the options above and more and use Outlook you
can use one of the Outlook object model examples on my mail index page.
Copy the code in a Standard module, if you just started with VBA see this page.
http://www.rondebruin.nl/code.htm
Check out this page for Tips If you want to change the code on this page.
http://www.rondebruin.nl/mail/tips1.htm
Example 1
Important :
1) The code is not working if your data is a List(Excel 2003) or Table(Excel2007)
2) The first row in the range must have Headers
3) Turn off AutoFilter before you use the code
4) Be sure that the sheet with the data is the active worksheet
In your worksheet you must have :
In column A : Names of the students or ?
In column B:H : Information about the student or ?
We filter the range A1:H? for every unique name in the name column (column A in this example)
For every unique name we create a new file with only the data of that person and send it to the
mail address it find with the VLookup function in the worksheet "Mailinfo".
Important: You must create this worksheet manual and add the names and mail addresses one time.
Add a worksheet to your workbook with the name "Mailinfo" with in column A the names
and in column B the mail addresses of every possible person in your Name column..
How do I Change filter range and filter column? :
In this example I use the filter range A1:H? (we use all the rows on the sheet)
You can change the filter range and filter column in this two code lines in the macro.
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A
Copy the macro below in a Standard module.
Example 2
Important :
1) The code is not working if your data is a List(Excel 2003) or Table(Excel 2007)
2) The first row in the range must have Headers
3) Turn off AutoFilter before you use the code
4) Be sure that the sheet with the data is the active worksheet
In your worksheet you must have :
In column A : Names of the students or ?
In column B : E-mail addresses
In column C:H : Information about the student or ?
Note: Every row must have a mail address in column B
We filter the range A1:H? for every unique mail address in column B.
For every unique mail address we create a new file with only the records with that
mail address and send it to that mail address.
How do I Change filter range and filter column? :
In this example I use the filter range A1:H? (we use all the rows on the sheet)
You can change the filter range and filter column in this two code lines in the macro.
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in A
Copy the macro below in a Standard module.
The code on this page is working with Outlook, Outlook Express and Windows Mail.
With SendMail it is not possible to :
1) Send text in the Body of the mail
2) Use the CC or BCC field
3) Attach other files
If you want to have the options above and more and use Outlook you
can use one of the Outlook object model examples on my mail index page.
Copy the code in a Standard module, if you just started with VBA see this page.
http://www.rondebruin.nl/code.htm
Check out this page for Tips If you want to change the code on this page.
http://www.rondebruin.nl/mail/tips1.htm
Example 1
Important :
1) The code is not working if your data is a List(Excel 2003) or Table(Excel2007)
2) The first row in the range must have Headers
3) Turn off AutoFilter before you use the code
4) Be sure that the sheet with the data is the active worksheet
In your worksheet you must have :
In column A : Names of the students or ?
In column B:H : Information about the student or ?
We filter the range A1:H? for every unique name in the name column (column A in this example)
For every unique name we create a new file with only the data of that person and send it to the
mail address it find with the VLookup function in the worksheet "Mailinfo".
Important: You must create this worksheet manual and add the names and mail addresses one time.
Add a worksheet to your workbook with the name "Mailinfo" with in column A the names
and in column B the mail addresses of every possible person in your Name column..
How do I Change filter range and filter column? :
In this example I use the filter range A1:H? (we use all the rows on the sheet)
You can change the filter range and filter column in this two code lines in the macro.
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A
Copy the macro below in a Standard module.
Sub Send_Row_Or_Rows_Attachment_1()
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
On Error GoTo cleanup
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0
If mailAddress <> "" Then
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail mailAddress, _
"This is the Subject line"
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Example 2
Important :
1) The code is not working if your data is a List(Excel 2003) or Table(Excel 2007)
2) The first row in the range must have Headers
3) Turn off AutoFilter before you use the code
4) Be sure that the sheet with the data is the active worksheet
In your worksheet you must have :
In column A : Names of the students or ?
In column B : E-mail addresses
In column C:H : Information about the student or ?
Note: Every row must have a mail address in column B
We filter the range A1:H? for every unique mail address in column B.
For every unique mail address we create a new file with only the records with that
mail address and send it to that mail address.
How do I Change filter range and filter column? :
In this example I use the filter range A1:H? (we use all the rows on the sheet)
You can change the filter range and filter column in this two code lines in the macro.
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in A
Copy the macro below in a Standard module.
Sub Send_Row_Or_Rows_Attachment_2()
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
On Error GoTo cleanup
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail Cws.Cells(Rnum, 1).Value, _
"This is the Subject line"
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub