我有一个宏，可以向每个人发送电子邮件（基于包含名称和电子邮件的选项卡）。 该宏可以完美地过滤和发送电子邮件，但是通过粘贴电子邮件正文来删除条件。
我希望发送包含条件格式的电子邮件-一旦这是一种仪表板，团队必须将重点放在红色项目上。
'GET DEFAULT EMAIL SIGNATURE
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
'for each coordinator
For Each probCoordName In Sheets("Coordinators_Contact").Range("A2:" & Sheets("Coordinators_Contact").Range("a200").End(xlUp).Address)
'find last row PBI
Sheets("Email_report").Activate
With ActiveSheet
LastRow = (.Cells(.Rows.Count, "A").End(xlUp).Row)
End With
Sheets("Email_report").Activate
'If Application.WorksheetFunction.CountIf(Range("I7:I" & LastRow), "*" & probCoordName & "*") > 0 Then
'filter by coordinator PBI
coordinatorPBI = probCoordName
'MsgBox Sheets("Email_report").PivotTable.Name
If coordinatorPBI = "" Then
MsgBox "Report sent out successfully!"
Sheets("Email_report").Activate
Sheets("Email_report").Range("A1").Select
Exit Sub
End If
ActiveSheet.PivotTables("PivotTable10").PivotFields("[PBI_ALL_P52].[ProblemCoordinator].[ProblemCoordinator]").VisibleItemsList = Array("[PBI_ALL_P52].[ProblemCoordinator].&[" & coordinatorPBI & "]")
'send email
Dim RNG As Range
Dim rngPKE As Range
Dim OutApp As Object
Dim OutMail As Object
Set RNG = Nothing
Set rngPKE = Nothing
'On Error Resume Next
' Only send the visible cells in the selection.
'select columns to report in email PBI
Sheets("Email_report").Activate
Sheets("Email_report").Range("A5:M" & LastRow).Select
Set RNG = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If RNG Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'.Display
.To = probCoordName.Offset(0, 1)
.CC = ""
.BCC = ""
.Subject = "PBI/PKE on going - Under your responsibility"
.HTMLBody = "Dear " & probCoordName & "." & "<br>" & "Find below the list of the PBI and PKE on going under your responsibility." & "<br>" & "<br>" & "Problem Investigation (PBI)" & RangetoHTML(RNG) & "<br>" & "<br>" & "Link to full report" & "<br>" & "<A href=\Linkfile</A>" & "<br>" & "<br>" & "Best Regards," & "<br>" & Signature
'"linkFile< /a>< br>"
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
'.Display
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set RNG = Nothing
'Clear Filters PBI
'end send email function
'End If
Next probCoordName