Доработка макроса

[ariwex]

Здравствуйте!

Постепенно стараюсь освоить создание макросов с нуля и благодаря вашему форуму и гуглу даже начинает получаться. Я написал макрос, который прикрепляю к этому посту. Его суть в том, что он проверяет пустая ли ячейка в третьем столбце, сравнивает дату во втором столбце с сегодняшней и при соблюдении условий отсылает эмеил через оутлук. В целом макрос работает, как я и задумывал, но теперь хотелось бы его немного изменить, но у меня совершенно нет идей, как это реализовать. Я бы хотел, чтобы макрос соблюдал все изначальные условия, но еще если в пятой колонке больше, чем одно совпадение по имени саплаера, то отсылался бы только один эмеил со всеми номерами из столбца 1, а не по отдельности. Надеюсь, что я понятно изложил свои мысли и это вообще возможно реализовать. Заранее благодарен за любую подсказку.

[Aleksandr H.]

Sub Send_Mail_Mass_1()
    
    
    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
    Dim Supplier As String
    Dim eMsg As String
    Dim dic As Object
    Dim varKey As Variant
    
    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
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    lLastR = Cells(Rows.Count, 1).End(xlUp).Row
    For lr = 2 To lLastR
        Supplier = Cells(lr, 5).Value
        
        If Cells(lr, 3) = "" And Date - Cells(lr, 2) > 5 Then
            
            If (dic.exists(Supplier)) Then
                dic(Supplier) = dic(Supplier) & "<br>" & "PO " & Cells(lr, 1) & " Pos." & Cells(lr, 4)
            Else
                dic.Add Supplier, "PO " & Cells(lr, 1) & " Pos." & Cells(lr, 4)
            End If

        End If
        
    Next lr
    
    For Each varKey In dic.keys()
        Set objMail = objOutlookApp.CreateItem(0)
           Email = Application.WorksheetFunction.VLookup(varKey, Sheet2.Range("A1:B1000"), 2, False)
            With objMail
                .To = Email
                .Subject = "Unconfirmed orders reminder"

                .HTMLBody = "<p>Hi,</p>" & _
                "<p>&nbsp;</p>" & _
                "<p>Please send us order confirmation.&nbsp;</p>" & _
                "<p>Unconfirmed orders:</p>" & _
                dic(varKey) & _
                "<p>&nbsp;</p>" & _
                "<p>Best Regards,</p>" & _
                "<p>&nbsp;</p>"
                .Send
                '.display
            End With
    Next
    
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub