Hi,
I have a Macro for sending outlook, but i want to modify it using attached mail templates:
Template 1, if there is 1 item that is more than 30 days (column C)
Template 2, if there are 2 or more items that are more than 30 days
Template 3, if there is no item that is more than 30 days.
Subject also varies depending on the template.
Thanks,
AkiAttachment 613Attachment 614Attachment 615
This should do most of the work.
Code:Option Explicit
Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
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 strSituation As String
Dim lngOutlier 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
Ash.AutoFilterMode = False
'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:G" & Ash.Cells(Rows.Count, 1).End(xlUp).Row)
FieldNum = 1 'Filter column = A because the filter range start in 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 = Cws.UsedRange.Rows.Count
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
lngOutlier = WorksheetFunction.CountIfs(FilterRange.Columns(1).Cells, Cws.Cells(Rnum, 1).Value, FilterRange.Columns(3).Cells, ">30")
Select Case lngOutlier
Case Is >= 1
strSituation = ">30"
Case Else
lngOutlier = WorksheetFunction.CountIfs(FilterRange.Columns(1).Cells, Cws.Cells(Rnum, 1).Value, FilterRange.Columns(3).Cells, "<=30")
strSituation = "<=30"
End Select
'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
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Test mail"
.body = MesgToPass(strSituation, lngOutlier)
.htmlbody = .htmlbody & RangetoHTML(rng) & MesgToPass("")
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
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
Function MesgToPass(strSituation As String, Optional lngOutlier As Long)
Dim str As String
Select Case strSituation
Case ">30"
If lngOutlier > 1 Then
str = "Hi Dear,"
str = str & vbCrLf & ""
str = str & vbCrLf & "We have " & lngOutlier & " open workflows which are open in the system for more than 30 days and were located in your inbox."
str = str & vbCrLf & ""
str = str & vbCrLf & "Have included workflows with average duration of 0-30 days so as not to wait for them to be delayed before we send another reminder. Kindly provide your support in closing/processing these open items as soon as possible. Our goal is to have no open workflow over 30 days. Please give advice if you're unable to do so due to some issues you're encountering. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
ElseIf lngOutlier = 1 Then
str = str & "Hi Dear,"
str = str & vbCrLf & ""
str = str & vbCrLf & "We have 1 open workflow which is open in the system for more than 30 days and is located in your inbox."
str = str & vbCrLf & ""
str = str & vbCrLf & "Kindly provide your support in closing/processing this open item as soon as possible. Our goal is to have no open workflow over 30 days. Please give advice if you're unable to do so due to some issues you're encountering. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
End If
Case "<=30"
str = str & "Hi Dear,"
str = str & vbCrLf & ""
str = str & vbCrLf & "See below workflows with average duration of 0-30 days that are located in your inbox and kindly prioritize these so it won't be delayed before we send another reminder. Please provide your support in closing/processing these open items as soon as possible. If workflow is incorrectly sent to your inbox, please advise workflow number and forwarder."
Case Else
str = str & vbCrLf & "<P><FONT FACE=""Calibri"">"
str = str & vbCrLf & ""
str = str & vbCrLf & ""
str = str & vbCrLf & "Hoping for your utmost cooperation."
str = str & vbCrLf & "<P><P></P></P>"
str = str & vbCrLf & "Thank you and Best Regards,</FONT></P>"
End Select
MesgToPass = str
End Function
Thank you for the help, but i still have one question, what if the subject changed depending also on the template to be sent.
1. if there are 2 or more items that are more than 30 day: the subject is "Multiple workflows with more than 30 days"
2. if only one item is more than 30 days: "Single WF with more than 30 days"
3. if no more thank 30 days: "Workflows without more than 30days"
Thanks in advance
Add this to the module
And in the subject line, useCode:Function SubjToPass(strSituation As String, Optional lngOutlier As Long)
Dim str As String
Select Case strSituation
Case ">30"
If lngOutlier > 1 Then
SubjToPass = "Multiple workflows with more than 30 days"
ElseIf lngOutlier = 1 Then
SubjToPass = "Single WF with more than 30 days"
End If
Case "<=30"
SubjToPass = "Workflows without more than 30days"
End Select
End Function
Code:.Subect = SubjToPass(strSituation, lngOutlier)
I have edited the macro, but when i save the macro to our shared folders, the macro won't work, do you have idea why? also there are cases which the macro work,
1. if i create a new file, copying all macro, then it works, but when i transfered or save the file from ather share folders, the macro is not working.
2. if it is save and wont work, i am running the VBA, then the open sheet is "Mailinfo" the macro is running but it copies the date from the said sheet.