Работал над проектом, который будет отправлять рассылку разным людям, если условия будут выполнены.
Условия:
- Столбец U содержит окончательный статус (открыто или WIP) (не будет отправлено, если закрыто, независимо от того, больше текущая дата)
- Столбец Q содержит дату закрытия. Что по сравнению с текущей датой, если меньше, чем автоматическая съемка почты для людей.
Я пытался сделать с для цикла, но он дает стрельбу 4 почты с теми же To и CC. И не собираюсь в следующий ряд сравнивать.
Сравнение ячеек V2 с Q2, затем следующий цикл V3 с Q3 и с той же стороны проверьте, есть ли у ячейки U2 "Open"
Заранее спасибо.
Код как ниже:
Sub Data_RoundedRectangle1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
On Error Resume Next
For i = 1 to 4
If Sheets("Data").Range("U2:U6").Value2 = "Open" Or Sheets("Data").Range("U2:U6").Value2 = "WIP" And (CDate(Cells(2, 17).Value) < Now()) Then
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Worksheets("Data").Cells(i, "C").Value2 = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value2 = "Quality_Assurance" Then
StrBody = "Hi," & "<br>" & _
.To = "a"
.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then
StrBody = "Hi," & "<br>" & _
"PFB the process details which requires your attention." & "<br>" & _
"The review for this process has crossed over due." & "<br>" & _
"Please ask the process owner to review the Process Manuals and Maps." & "<br><br><br>"
.To = "c"
.CC = "d"
.BCC = ""
.Subject = "Process Manual and Maps Review is Overdue"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send
End If
End With
i = i + 1
Exit For
End If
End If
Next r
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next x
End Sub
