I have posted the Excel 2013 workbook to SkyDrive:
Hello Kim,
Hope it all works for you. You should be able to copy the code below into your workbook and run it.
What the code does:-
- Firstly I have written the code so that you do not need to set the Reference in Tools -> References to Outlook. This is called late binding and the advantage is that it should work with any version of Outlook. (Using early binding can cause problems with
compatibility of earlier versions of Outlook.)
- Copies the data from the Pivot to a temporary worksheet so that AutoFilter can be applied. (Also copies some formatting but this part is not really necessary other than I used it during testing.)
- Copies the email addresses to another temporary worksheet and removes the duplicates.
- Loops through the unique list of email addresses and sets the filter to each email address in turn.
- Copies the visible Projects for the email address to a variable.
- Creates a variable for the email body from the required data and extracts the recipients name and the date from the first row to use in the body.
- Uses the created strings to set the email parameters for Subject, Body etc.
- Uses the value of the range variable that is used to loop through the unique list of email addresses as the recipient.
- Saves the emails to the Drafts folder.
- Deletes the temporary worksheets.
Feel free to get back to me with an queries. I have tested and placed all emails in my Drafts folder.
Code has been edited since initial posting with additional functionality as requested.
Sub Email()
'Code uses late binding.
'DO NOT set the Reference to Outlook in the Tools -> References
Dim objOutlook As Object 'Uses late binding
Dim objMailItem As Object 'Uses late binding
Const cstMailItem = 0 'Required when late binding used
Const cstImportanceHigh = 2 'Required when late binding used
Dim wsPivot As Worksheet
Dim wsCopy As Worksheet
Dim wsUnique As Worksheet
Dim rngToFind As Range
Dim rngUnique As Range
Dim celUniq As Range
Dim celProj As Range
Dim rngFilt As Range
Dim strBody As String
Dim strProjs As String
Dim strSubject As String
Set wsPivot = Worksheets("Email3") 'Pivot output. (Edit "Email3" if not correct name)
'Test if SendEmail column has at least one "Y" otherwise terminate the processing
If WorksheetFunction.CountIf(wsPivot.Columns("G:G"), "Y") = 0 Then
MsgBox "There are no ""Y"" values in SendEmail column." & vbCrLf & _
"Processing terminated."
Set wsPivot = Nothing
Exit Sub
End If
Set wsCopy = Sheets.Add(After:=Sheets(Sheets.Count)) 'Add temporary worksheet for copy of data
Set wsUnique = Sheets.Add(After:=Sheets(Sheets.Count)) 'Add temporary worksheet for unique list of email addresses
wsPivot.Cells.Copy 'Copy data from Pivot
wsCopy.Cells(1, 1).PasteSpecial Paste:=xlPasteValues 'Paste values only to temporary worksheet.
With wsCopy
wsPivot.Rows("1:1").Copy 'Copy first row of Pivot for transferring format to temp copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats 'Paste the formats so they look like dates in row 1
wsPivot.Columns("B:B").Copy 'Copy column B of Pivot for transferring format to temp copy
.Cells(1, "B").PasteSpecial Paste:=xlPasteFormats 'Paste formats so they look like dates in column B
'Add a Column headers to blank cell ready for AutoFilter
.Cells(3, "B") = "Date"
.Cells(3, "C") = "Col_C"
'Turn on AutoFilter
.Range(.Cells(3, "B"), .Cells(3, .Columns.Count).End(xlToLeft)).AutoFilter
.Columns.AutoFit
End With
With wsCopy
'Set filter to display only records with "Y" in SendEmail column
.AutoFilter.Range.AutoFilter Field:=6, Criteria1:="Y"
'Copy the column of visible email addresses from wsCopy copy to wsUnique worksheet
'No need to test here if any records displayed due to
'previous test for at least one "Y" in column of initial data.
With .AutoFilter.Range
.Columns(3).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wsUnique.Cells(1, 1)
End With
wsUnique.Columns.AutoFit
End With
With wsUnique
'Remove duplicate email addresses from temporary list
.Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
End With
'Remove the name "(Blank)" from the unique list
'Probably not required now only SendEmail = "Y" included but have left in place anyway
With wsUnique
Set rngToFind = .Columns(1).Find(What:="(blank)", _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rngToFind Is Nothing Then
rngToFind.EntireRow.Delete
End If
End With
With wsUnique
'Assign unique list of email addresses to a range variable
Set rngUnique = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
'Set up Outlook once before going into the loop
'Test if Outlook already open
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
With wsCopy
'Start the loop. Cycle through the temporary Unique list of email addresses
For Each celUniq In rngUnique
.AutoFilter.Range.AutoFilter Field:=3, Criteria1:=celUniq.Value
'Assign visible data only without column headers to a range variable
With .AutoFilter.Range.Columns(8)
Set rngFilt = .Offset(1, 0) _
.Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
End With
'Create a string with line feeds for the Clients, Projects and Hours.
'by looping through the visible rows of data.( Chr(9) is a tab.)
strProjs = ""
For Each celProj In rngFilt
strProjs = strProjs & vbCrLf & "Project" & Chr(9) & ": " & celProj.Offset(0, -1) _
& ", " & celProj.Value & vbCrLf & "Hours" & Chr(9) & ": " _
& celProj.Offset(0, -6) & vbCrLf
Next celProj
'Create a string for the body of the email
strBody = "" 'Start with zero length string for each email recipient
With rngFilt
strBody = "Hi, " & .Cells(1, 1).Offset(0, -3) & ", " & vbLf & vbLf & _
"This week (commencing " & Format(.Cells(1, 1).Offset(0, -7), "MMMM D, YYYY") & ")" _
& " you should be working on the following project(s):" & _
vbCrLf & strProjs & _
vbLf & "If this is not your understanding based on your project PM's " _
& "instruction, please inform Patty Yuen asap."
'Create a string for the Subject of the email
strSubject = "Your staffing for the upcoming week, " _
& Format(.Cells(1, 1).Offset(0, -7), "MMMM D, YYYY")
End With
Set objMailItem = objOutlook.CreateItem(cstMailItem)
'set Importance indicator on email message
objMailItem.Importance = cstImportanceHigh
'Set Subject of email message
objMailItem.Subject = strSubject
objMailItem.Body = strBody
'Set email recipient (who is resource whose hours are captured in the email)
objMailItem.Recipients.Add celUniq.Value
'below is for sending email out immedaitely
'objMailItem.Send
'below is for displaying email without sending
'objMailItem.Display
'below is to put emails all in Outlook draft folder to be manually sent from there
objMailItem.Save
Next celUniq
End With
'Return to initial worksheet (code selects worksheet and cell in one line)
Application.Goto wsPivot.Cells(1, 1)
'Delete temporary worksheets. (Comment out if you want to see what is in them)
Application.DisplayAlerts = False
wsUnique.Delete 'Delete unique list of email addresses worksheet
wsCopy.Delete 'Delete copy of pivot data worksheet
Application.DisplayAlerts = True
'Cleanup of object variables
Set celUniq = Nothing
Set celProj = Nothing
Set rngToFind = Nothing
Set rngUnique = Nothing
Set rngFilt = Nothing
Set wsPivot = Nothing
Set wsCopy = Nothing
Set wsUnique = Nothing
Set objOutlook = Nothing
Set objMailItem = Nothing
End Sub
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
