Создание тела электронной почты Outlook со строками, имеющими определенное значение, с помощью Excel VBA

Question

Я использовал пример для создания кода для отправки электронных писем из Excel (с Outlook), используя «кнопку» (красная в моем файле).

Код работает.Существует предварительно выбранный диапазон строк [B1: K20], который можно изменить вручную благодаря функции Application.InputBox .

Sub MAIL()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBodyIn, StrBodyEnd As String

StrBodyIn = "Bonjour," & "<br>" & _
           " " & "<br>" & _
          "Buongiorno," & "<br>"

StrBodyEnd = " " & "<br>" & _
             "Cordialement" & "<br>" & _
             " " & "<br>" & _
             Range("M2") & "<br>"

Set rng = Nothing

On Error Resume Next
Set rng = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "ATTENZIONE!!!" & _
           vbNewLine & "Seleziona un range di celle valido.", 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
    .To = "email@gmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "SITUATION"
    .HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
    .Display 'or use .Send
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Я хочу добавитьусловие.

Выбранный диапазон строк должен быть скопирован в тело письма, если в столбце «А» указан символ «X».

В моем примере, строки № 1, 2 и № 5 должны быть скопированы.

Answer 1

Две задачи здесь раздельные, поэтому я бы написал их так.Вот мой подход.Разделите ваш саб на две логические процедуры.

1. Определение диапазона тела
2. Отправка электронного письма с диапазоном

---

Определение диапазона тела

Ссылка на кнопкук этому макросу.Макрос возьмет входные данные и преобразует его в один диапазон столбцов (Column B).Затем мы пройдемся по выбранному диапазону и посмотрим на Column A, чтобы определить, есть ли x или нет.Если присутствует x, мы изменим диапазон до его первоначального размера и добавим его в коллекцию ячеек (Final).

Когда цикл завершится, макрос выполнит одно из следующих действий:

1. Если диапазон пуст, появится окно с сообщением и конец подпрограммы (адрес электронной почты).макрос никогда не запускается)
2. Если диапазон не пустой, мы назовем ваш макрос EMAIL и передадим ему диапазон.

Sub EmailRange()

Dim Initial As Range, Final As Range, nCell As Range

On Error Resume Next
    Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0

For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
    If nCell.Offset(, -1) = "X" Then
        If Not Final Is Nothing Then
            Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
        Else
            Set Final = nCell.Resize(1, Initial.Columns.Count)
        End If
    End If
Next nCell

If Not Final Is Nothing Then
    MAIL Final
Else
    MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If

End Sub

---

Отправьте электронное письмо с диапазоном

Обратите внимание, что макрос теперь имеет ввод (в первой строке).Если вызывается подпрограмма, вам больше не нужно ничего проверять, поскольку все это было сделано в исходном подпрограмме!

Sub MAIL(Final as Range)

Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String

StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"

Application.EnableEvents = False
Application.ScreenUpdating = False

  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
        With OutMail
            .To = "email@gmail.com"
            .CC = ""
            .BCC = ""
            .Subject = "SITUATION"
            .HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
            .Display 'or use .Send
        End With
    On Error GoTo 0

  Set OutMail = Nothing
  Set OutApp = Nothing

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub