массовая рассылка через outlook

[Dimitriusik]

Добрый день!
В листе в первой колонке присутсвуют e-mail. Во второй колонке тема сообщения, в третьей колонке текст сообщения и в четвертой колонке прикрепление файла.
Нужно изменить данный макрос так чтоб отправляло только тем адресатам, у которых будет вложение к письму (то есть если найдется файл по адресу в колонке 4. Сам я плохо понимаю программирование, помогите кто может

Sub Рассылка()

    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim lr As Long, lLastR As Long
 
    Application.ScreenUpdating = False
    On Error Resume Next
    
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    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
        End With
    Next lr
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True

End Sub

_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор

[Aleksandr H.]

Постате условие после начала цикла If cells(lr,4)<>"" then
......
End if

[Dimitriusik]

Сообщение от Aleksandr H.

Постате условие после начала цикла If cells(lr,4)<>"" then
......
End if

Все равно отправляет сообщение без вложения.

[Aleksandr H.]

На 97% уверен что не там условие стоит, но раз Вам сложно привести код который

Сообщение от Dimitriusik

Все равно отправляет сообщение без вложения

...

[vefer]

Сообщение от Aleksandr H.

На 97% уверен что не там условие стоит, но раз Вам сложно привести код который

Думаю проще написать

Sub Рассылка()

    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim lr As Long, lLastR As Long
 
    Application.ScreenUpdating = False
    On Error Resume Next
    
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    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 Cells(lr, 4)<>"" then
        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
        End With
     end if
    Next lr
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True

End Sub