Как отправить электронное письмо со списком строк после проверки цикла

Question

Я новичок в форуме. У меня есть небольшая проблема с макросом VBA в Excel. Возможно, это не так сложно для вас, но я абсолютно новичок в VBA. У меня есть два столбца: столбец «A» с выбором (например, «да» или «нет») и столбец «B» со строкой. Я хочу отправить электронное письмо со списком строк "B" со всеми строками (построчно), которые имеют значение "да" в "A".

Sub Alert()
ActiveSheet.UsedRange.Select
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim list As Object
Dim element As Variant

Application.ScreenUpdating = False

Do While Trim(Cells(cell.Row, "A").Value) = ""
On Error GoTo alertmail
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
 If cell.Value = "yes" Then
  element = Cells(cell.Row, "B").Value
    Set list = CreateObject("System.Collections.ArrayList")
    list.Add element
 End If
Next cell
Loop

alertmail:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
            .To = "test@abc.com"
            .Subject = "Alert"
            .Body = "Your yes list is" & vbNewLine & PrintArray
            .Display
End With
        On Error GoTo 0
        Set OutMail = Nothing

Exit Sub

Application.ScreenUpdating = True

End Sub

До сих пор моим лучшим результатом была отправка набора различных писем только с одной строкой "B" для каждого значения "да" и "A" (т. Е. Если у меня есть значение 3 "да", я получаю 3 письма с правильными Строка "B" для каждого).

Answer 1

Попробуйте следующий код:

Sub Alert()
    ActiveSheet.UsedRange.Select
    On Error Resume Next
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim list As String
    Dim element As Variant

    Application.ScreenUpdating = False

    Do While Trim(Cells(cell.Row, "A").Value) = ""
    On Error GoTo alertmail
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value = "yes" Then
            element = Cells(cell.Row, "B").Value
            list = list & vbNewLine & element
        End If
    Next cell
    Loop

alertmail:
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
                .To = "to@xyz.com"
                .Subject = "Alert"
                .Body = "Your yes list is" & vbNewLine & list
                .Display
    End With
            On Error GoTo 0
            Set OutMail = Nothing

    Exit Sub

    Application.ScreenUpdating = True
End Sub