Outlook Excel VBA Макросы: Отправка писем на те адреса, для которых имеются файлы.

[Rengame113]

Как можно изменить код чтобы осуществлялась рассылка только на те эл адреса для которых имеются файлы.

Макрос

Option Explicit

Sub Send_Mail_Mass()
    Dim objOutlookApp As Object, objMail As Object
    Dim lr As Long, lLastR As Long

    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    objOutlookApp.Session.Logon

    lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
    'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
    For lr = 2 To lLastR
        Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
        'создаем сообщение
        With objMail
            .to = Cells(lr, 1).Value 'адрес получателя
            .Subject = Cells(lr, 2).Value 'тема сообщения
            .Body = Cells(lr, 3).Value 'текст сообщения
            .Attachments.Add Cells(lr, 4).Value
            .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        End With
    Next lr

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

[свернуть]

[вложение удалено администратором]

[Администратор]

Макрос

Sub Send_Mail_Mass()
    Dim objOutlookApp As Object, objMail As Object
    Dim lr As Long, lLastR As Long

    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    objOutlookApp.Session.Logon

    lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
    'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
    For lr = 2 To lLastR
       
        ' Если файла нет, то переход на следующую строку.
        If Dir(Cells(lr, 4).Value) = "" Then
            GoTo metka_NextRow
        End If
       
        ' Создание письма.
        Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
        'создаем сообщение
        With objMail
            .to = Cells(lr, 1).Value 'адрес получателя
            .Subject = Cells(lr, 2).Value 'тема сообщения
            .Body = Cells(lr, 3).Value 'текст сообщения
            .Attachments.Add Cells(lr, 4).Value
            .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        End With
       
metka_NextRow:
    Next lr

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

[свернуть]

[Rengame113]

Спасибо. Все работает.