问根据特定单元格内容发送电子邮件

EN

Option Explicit

Sub main()
    Dim pingResults As Range, cell As Range

    With Sheets("Ping")
        With .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
            .AutoFilter Field:=1, Criteria1:="Request timed out."
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set pingResults = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
        End With
        .AutoFilterMode = False
    End With

    If Not pingResults Is Nothing Then
        With CreateObject("Outlook.Application")
            For Each cell In pingResults
                With .CreateItem(0) '<--| olMailItem is an item of an OutLook enumeration whose value is "zero"
                    .Display
                    .to = cell.Offset(, 1).Value
                    .Subject = cell.Offset(, -3) & " " & "-" & " " & cell.Offset(, -2) & " " & "-" & " " & cell.Offset(, -1)
                    .Body = "Run Diagnostics.  Customer's broadband appears to have issues" & vbCrLf & cell.Value
                    .Save
                End With
                SendKeys "%{s}", True
            Next
            .Quit
        End With
    End If    
End Sub

Dim OutlookApp
Dim objMail
Dim x As Long
Dim PingResults As Range

Set OutlookApp = CreateObject("Outlook.Application")
lastrow = Sheets("Ping").Cells(Rows.Count, 1).End(xlUp).Row
Set PingResults = Range("d1:D" & lastrow)

For x = 2 To lastrow

    If PingResults.Cells(x, 1).Value = "Request timed out." Then
        Set objMail = OutlookApp.CreateItem(olMailItem)

        With objMail
            .To = Cells(x, 5).Value
            .Subject = Cells(x, 1) & " " & "-" & " " & Cells(x, 2) & " " & "-" & " " & Cells(x, 3)
            .Body = "Run Diagnostics.  Customer's broadband appears to have issues" & vbCrLf & Cells(x, 4)
            .Display
            .Save
        End With

        SendKeys "%{s}", True
        Set objMail = Nothing

    End If
Next x
Set OutlookApp = Nothing