VBA Mails

[MikoSDS]

Hello All,


I have a small problem but I have no idea how to solve this, so I want to send a few emails to one person, just not one by one like in the code, but as package or something.


For example:


Mail to Mr.A where's assigned a few positions should be send in one mail. In mailbody will be text + the numbers, which are assigned to him, but subject will be only "Reminder". But for Mr.BB, where's only one position the number should be send in subject + the "Reminder" like in the code.

Column A: Column B:

[TABLE="width: 493"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Mr.A@mail.com[/TD]
[TD]#10288014 [/TD]
[/TR]
[TR]
[TD]Mr.A@mail.com[/TD]
[TD]#10288015[/TD]
[/TR]
[TR]
[TD]Mr.A@mail.com[/TD]
[TD]#10288016[/TD]
[/TR]
[TR]
[TD]Mr.A@mail.com[/TD]
[TD]#10288017[/TD]
[/TR]
[TR]
[TD]Mr.A@mail.com[/TD]
[TD]#10288018[/TD]
[/TR]
[TR]
[TD]Mr.BB@mail.com[/TD]
[TD]#10288019[/TD]
[/TR]
[TR]
[TD]Mr.CC@mail.com[/TD]
[TD]#10288020[/TD]
[/TR]
[TR]
[TD]Mr.DD@mail.com[/TD]
[TD]#10288021[/TD]
[/TR]
[TR]
[TD]Mr.EE@mail.com[/TD]
[TD]#10288022[/TD]
[/TR]
[TR]
[TD]Mr.FF@mail.com[/TD]
[TD]#10288023[/TD]
[/TR]
</tbody>[/TABLE]

   LR = Cells(Rows.Count, 2).End(xlUp).Row
    For x = 2 To LR
    
        nr = nr + 1
        
        MailFrom = Sheets("Start").Cells(2, 2).Value
        MailTo = Range("A" & x).Value
        MailSubject = "Reminder " & Range("B" & x).Value
        MailBody = Sheets("Start").Cells(5, 2)
        
            Set OutlookApp = CreateObject("Outlook.application")
            Set OutlookMailitem = OutlookApp.CreateItem(0)
            
            With OutlookMailitem
                .Display
                .SentOnBehalfOfName = MailFrom
                .To = MailTo
                .Subject = MailSubject
                .Body = MailBody
                .Send
            End With
            
            Set OutlookMail = Nothing
            Set OutlookApp = Nothing
    Next x

Thank you all for help.

 

[DanteAmor]

Try this

Sub test_mail()
    Dim OutlookMailitem As Object
    Dim MailFrom As String, MailTo As String, MailSubject As String, MailBody As String
    Dim ant As String, cad As String
    Dim lr As Long, i As Long, n As Long
    
    ant = Cells(2, "A").Value
    cad = ""
    n = 0
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lr + 1
        If ant <> Cells(i, "A").Value Then
            Set OutlookMailitem = CreateObject("Outlook.application").CreateItem(0)
            
            MailTo = ant
            MailFrom = Sheets("Start").Cells(2, 2).Value
            MailBody = Sheets("Start").Cells(5, 2).Value
            MailSubject = "Reminder "
            If n = 1 Then MailSubject = MailSubject & cad Else MailBody = MailBody & " " & cad
            
            With OutlookMailitem
                .SentOnBehalfOfName = MailFrom
                .To = MailTo
                .Subject = MailSubject
                .Body = MailBody
                .Display
                .Send
            End With
            
            Set OutlookMailitem = Nothing
            cad = ""
            n = 0
        End If
        n = n + 1
        ant = Cells(i, "A").Value
        cad = cad & " " & Cells(i, "B").Value
    Next
        
    MsgBox "End"
End Sub

 

[MikoSDS]

Hello Dante,

Works perfect! Thank you so much!

 

[DanteAmor]

You're welcome and thanks for the feedback.