发送电子邮件到单元格中的电子邮件地址（如果有）

Question

我有三列（“O”、“Q”、“S”），它们使用 VLOOKUP 从输入的人名中获取电子邮件地址。 我希望这些人都收到一封电子邮件，其中包含一些详细信息。

如果三列中的任何列中都没有电子邮件值，我不希望此代码运行。 如果三列中的任何一列有电子邮件地址，我希望代码运行。

此代码检查单元格是否包含电子邮件地址，然后向该电子邮件地址发送电子邮件。 我需要所有三个单元格都需要这个，我需要将它们全部通过电子邮件发送。

If emailbox.Value = True Then

    On Error Resume Next
    i = ActiveCell.Row                  'VLOOKUP
    Sheet2.Cells(i, 15).Value = Application.WorksheetFunction.VLookup(Sheet2.Cells(i, 14).Value, Sheet3.Range("AMS"), 2, 0)

    On Error Resume Next
    i = ActiveCell.Row                  'VLOOKUP
    Sheet2.Cells(i, 17).Value = Application.WorksheetFunction.VLookup(Sheet2.Cells(i, 16).Value, Sheet3.Range("AQE"), 2, 0)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup

    For Each cell In Sheet2.Range("O" & ActiveCell.Row)
        If cell.Value Like "?*@?*.?*" Then 'Check cell for email address

            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = cell.Value
                .Subject = "SUBJECT"
                .Body = "Dear...."
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing

            sent.Visible = True
            Else
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End If

Answer 1

循环遍历column O每个单元格，并测试所有三个单元格中是否有一封电子邮件，当它遇到一封电子邮件时，它将执行其余代码，并退出内部循环。

Dim cel As Range, lRow As Long, x As Long
lRow = ActiveSheet.Cells(Rows.Count, 15).End(xlUp).Row

    For Each cel In Range("O2:O" & lRow)
        For x = 15 To 19 Step 2 'loop through each cell in the active row

            If Cells(cel.Row, x).Value Like "?*@?*.?*" Then
                'email .To = Cells(cel.Row, x).Value
                Exit For 'exits the inner loop when the condition is met
            End If

        Next x

    Next cel