Excel VBA Outlook - получатели электронной почты Dynami c

Question

В настоящее время я пытаюсь создать код, который будет отправлять электронную почту выбранным получателям на основе того, соответствует ли ячейка в Excel указанным c критериям, в данном случае «да». У меня был ограниченный успех в работе кода, но он будет отправлять только первому пользователю в диапазоне, который видит критерии «да». Вот код, с которым я сейчас работаю:

Sub Read_Emails()

' SET Outlook APPLICATION OBJECT.

Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

For Each cell In Columns("N").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "R").Value) = "yes" Then

With objEmail
    .To = cell.Value
    .CC = ""
    .Subject = "Subject here"
    .BodyFormat = olFormatHTML
    .HTMLBody = "Hello," & "<p>" & "Message here."
    .Send
End With
End If
Next cell


Set objEmail = Nothing
Set objOutlook = Nothing

End Sub

Answer 1

Я смог решить эту проблему самостоятельно, используя https://www.rondebruin.nl/win/s1/outlook/bmail5.htm.

Код ниже для тех, кто интересуется подобной проблемой:

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 Columns("L").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "P").Value) = "yes" Then

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = cell.Value
            .Subject = "Subject here"
            .Body = "Hello " & Cells(cell.Row, "K").Value & "," _
              & vbNewLine & vbNewLine & _
                    "Message here."
            'You can add files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send  'Or use Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If
Next cell

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