hi all, i would really appreciate some help with an email macro i use at work. i have a workbook containing (this month) some 1300 entries. each entry represents a supervisor that has not approved a leave app and its is pending, and requires action.
The macro looks in column "aa" (email address) opens a new outlook email populates the email address and attaches a new workbook containing the row = to the email address.
What i would like is for the macro to group all the lines applicable to each supervisor. This way the supervisor receives one email and not an email for each listed row (ie a supervisor may receive 40-50 individual emails) I have the macro go to "display" every 11 seconds as i have to select a tidus classification in outlook for each email. Odd results I ran a test of 300 entries within the workbook, and at the end I had only sent out 163 email ( i am not sure why it did not send all 300 emails)
Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2013
Dim OutApp As Object
Dim OutMail As Object
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
Set OutApp = CreateObject("Outlook.Application")
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:AA" & Ash.Rows.Count) 'this value is the range of cloumns required to send in each email
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 worksheetm, this value is the range of cloumns required to send in each email
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:AA" & _
Worksheets("Mailinfo").Rows.Count), 27, False) ' This column value is equal to the column address of the email address
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 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "DataQuality@xxx.xxx.au"
.To = mailAddress
.Subject = "PSS - Unprocessed Leave Applications [SEC=UNCLASSIFIED]"
.Attachments.Add NewWB.FullName
.Body = "Reference:" & vbNewLine & vbNewLine & _
"A. DI(G) ADMIN 60-2, xxx Leave Administration - Policy and Management" & vbNewLine & vbNewLine & _
"B. OCA MINUTE OCA/OUT/2009/R4029263 dated 19 Jun 09 – PMKeyS Self Service – Leave" & vbNewLine & vbNewLine & _
" " & vbNewLine & vbNewLine & _
"Good morning, an unprocessed PSS leave report has been generated by etc, etc"
'.Send 'Use display for testing Or use Send
.display
Application.Wait (Now + TimeValue("0:00:11"))
Application.SendKeys "%s"
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
The macro looks in column "aa" (email address) opens a new outlook email populates the email address and attaches a new workbook containing the row = to the email address.
What i would like is for the macro to group all the lines applicable to each supervisor. This way the supervisor receives one email and not an email for each listed row (ie a supervisor may receive 40-50 individual emails) I have the macro go to "display" every 11 seconds as i have to select a tidus classification in outlook for each email. Odd results I ran a test of 300 entries within the workbook, and at the end I had only sent out 163 email ( i am not sure why it did not send all 300 emails)
Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2013
Dim OutApp As Object
Dim OutMail As Object
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
Set OutApp = CreateObject("Outlook.Application")
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:AA" & Ash.Rows.Count) 'this value is the range of cloumns required to send in each email
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 worksheetm, this value is the range of cloumns required to send in each email
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:AA" & _
Worksheets("Mailinfo").Rows.Count), 27, False) ' This column value is equal to the column address of the email address
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 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "DataQuality@xxx.xxx.au"
.To = mailAddress
.Subject = "PSS - Unprocessed Leave Applications [SEC=UNCLASSIFIED]"
.Attachments.Add NewWB.FullName
.Body = "Reference:" & vbNewLine & vbNewLine & _
"A. DI(G) ADMIN 60-2, xxx Leave Administration - Policy and Management" & vbNewLine & vbNewLine & _
"B. OCA MINUTE OCA/OUT/2009/R4029263 dated 19 Jun 09 – PMKeyS Self Service – Leave" & vbNewLine & vbNewLine & _
" " & vbNewLine & vbNewLine & _
"Good morning, an unprocessed PSS leave report has been generated by etc, etc"
'.Send 'Use display for testing Or use Send
.display
Application.Wait (Now + TimeValue("0:00:11"))
Application.SendKeys "%s"
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
