Как отправить одно письмо всем людям в столбце

Question

Я нашел макросы для отправки электронного письма каждому человеку в столбце.

В столбце B показаны имена, для которых в столбце C указано «Да». Я добавил это условие в Power Query.

Sub Send_Row_Or_Rows_Attachment_1()
    'Working in 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Dim intHowManyRows As Integer

    With Application
        .ScreenUpdating = False
    End With
    intHowManyRows = Application.Range("B2").CurrentRegion.Rows.Count

    For r = 1 To intHowManyRows
        'Save, Mail, Close and Delete the file
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
            ' Cells(r, 2).Value
            .Subject = Cells(r, 3).Value
            '.Attachments.Add FullName  -> If you want to add attachments
            .Body = "Hi there" & vbNewLine & vbNewLine & "How are you " & Cells(r, 2)
            .Display  'Or use Send
        End With
    Next r

    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Или:

Sub Test2()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
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("B").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
      LCase(Cells(cell.Row, "C").Value) = "yes" Then
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = ThisWorkbook.Sheets("Sheet3").Range("B1").Value
            .Subject = "Reminder"
            .Body = "Dear " & Cells(cell.Row, "A").Value _
                  & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & _
                    "your account up to date"
            '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

Я хочу создать одно письмо Outlook со всеми людьми в столбце B в поле «Кому», а также прикрепить файл.

Answer 1

Я скорректировал код Рона. Посмотрите мои комментарии и настройте его в соответствии с вашими потребностями.

РЕДАКТИРОВАТЬ: В соответствии с предложением Нитона удалите возобновление при следующей ошибке и посмотрите, какая строка вызывает ошибку.

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Adapted by Ricardo Diaz ricardodiaz.co
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table1").ListObject ' -> Set the table's name

    On Error GoTo cleanup


    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)


    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please contact us to discuss bringing " & _
                "your account up to date"

        'You can add files also like this
        .Attachments.Add ("C:\test.txt") ' -> Adjust this path

        .Send ' -> Or use Display
    End With

    Set OutMail = Nothing

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

Дайте мне знать, если это работает.