Отправить письмо на разные адреса из ячеек

Question

У меня в «Листе 1» множество адресов электронной почты, в столбцах K, M, O, Q, S, U, W, Y, AA.
Я хочу создать письмо, которое будет отправлено на все адресавзято из последнего ряда в Sheet1.То же самое для данных в теле письма, взятых из последней строки.

Dim MonOutlook As Object
Dim MonMessage As Object
Dim EmailTo As String

With Worksheets("Sheet1")
    EmailTo = .Range("K" & ligne) & ";" & .Range("M" & ligne) & ";" & .Range("O" & ligne) & ";" & .Range("Q" & ligne) & ";" & .Range("S" & ligne) & ";" & .Range("U" & ligne) & ";" & .Range("W" & ligne) & ";" & .Range("Y" & ligne) & ";" & .Range("AA" & ligne)
End With

Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)

    MonMessage.To = ""
    MonMessage.Cc = ""
    MonMessage.Bcc = EmailTo
    MonMessage.Subject = "Rate request" & " " & "for" & " " & ThisWorkbook.Sheets("Sheet1").Range("B" & ligne)
    MonMessage.body = "Hello,"
                Chr (13) & Chr(13) & "Please send me rate for" & " " & ThisWorkbook.Sheets("Sheet1").Range("G" & ligne) & " " & "rooms on basis" & " " & ThisWorkbook.Sheets("Sheet1").Range("H" & ligne) & _
                Chr(13) & Chr(13) & "in hotel:" & " " & ThisWorkbook.Sheets("Sheet1").Range("J" & ligne) & _
                Chr(13) & Chr(13) & "for the period" & " " & ThisWorkbook.Sheets("suivi").Range("C" & ligne) & " " & ThisWorkbook.Sheets("Sheet1").Range("D" & ligne) & _
                Chr(13) & Chr(13) & "Thank you!" & _
                Chr(13) & Chr(13) & Application.UserName & " " & "-" & " " & "x Tours"

    MonMessage.Display

    With ThisWorkbook.Sheets("Sheet1").Range("AB" & ligne)
        .Value = Date
        .NumberFormat = "dd/mm/yyyy"
    End With

    ActiveWorkbook.Save

Answer 1

Попробуйте код ниже, объяснения внутри комментариев кода.

Option Explicit

Sub EmailContactsLastRow()

Dim MonOutlook As Object
Dim MonMessage As Object
Dim EmailSht As Worksheet
Dim EmailTo As String
Dim ligne As Long

' set the worksheet object
Set EmailSht = ThisWorkbook.Sheets("Sheet1")

With EmailSht
    ligne = .Cells(.Rows.Count, "K").End(xlUp).Row ' get last row with data in column K

    EmailTo = .Range("K" & ligne) & ";" & .Range("M" & ligne) & ";" & .Range("O" & ligne) & ";" & _
            .Range("Q" & ligne) & ";" & .Range("S" & ligne) & ";" & .Range("U" & ligne) & ";" & _
            .Range("W" & ligne) & ";" & .Range("Y" & ligne) & ";" & .Range("AA" & ligne)
End With

Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)

With MonMessage
    .To = ""
    .Cc = ""
    .Bcc = EmailTo
    .Subject = "Rate request" & " " & "for" & " " & EmailSht.Range("B" & ligne)
    .body = "Hello,"
                Chr (13) & Chr(13) & "Please send me rate for" & " " & EmailSht.Range("G" & ligne) & " " & "rooms on basis" & " " & EmailSht.Range("H" & ligne) & _
                Chr(13) & Chr(13) & "in hotel:" & " " & EmailSht.Range("J" & ligne) & _
                Chr(13) & Chr(13) & "for the period" & " " & EmailSht.Range("C" & ligne) & " " & EmailSht.Range("D" & ligne) & _
                Chr(13) & Chr(13) & "Thank you!" & _
                Chr(13) & Chr(13) & Application.UserName & " " & "-" & " " & "x Tours"

    .Display ' <-- this displays the email. not sending it
    .send ' <-- this sends the email out
End With

With EmailSht.Range("AB" & ligne)
    .Value = Date
    .NumberFormat = "dd/mm/yyyy"
End With

ThisWorkbook.Save

End Sub