Sending e-mail, multiple attachment, different names VBA

[gallzsoltv]

Hello!

A have a working macro (sending email), but I want to upgrade it.



Here is the excel sheet "Munka1":

[TABLE="width: 788"]
<colgroup><col><col><col><col></colgroup><tbody>[TR]
[TD].to[/TD]
[TD].cc[/TD]
[TD].body[/TD]
[TD].attachments[/TD]
[/TR]
[TR]
[TD]smith@gmail.com[/TD]
[TD]cc@cc.com; [email]bb@bb.com[/EMAIL][/TD]
[TD]HI ALL[/TD]
[TD]C:\Users\gall\Desktop\Test\Smith Jackson_tomorrow_201812.xlsx[/TD]
[/TR]
[TR]
[TD]joe@gmail.com[/TD]
[TD]cc@cc.com; [email]bb@bb.com[/EMAIL][/TD]
[TD]HI ALL[/TD]
[TD]C:\Users\gall\Desktop\Test\Joe Simon data_sending_201812.xlsx[/TD]
[/TR]
[TR]
[TD]neo@gmail.com[/TD]
[TD]cc@cc.com; [email]bb@bb.com[/EMAIL][/TD]
[TD]HI ALL[/TD]
[TD]C:\Users\gall\Desktop\Test\Neo James_data sending_201812.xlsx[/TD]
[/TR]
[TR]
[TD]neo@gmail.com[/TD]
[TD]cc@cc.com; [email]bb@bb.com[/EMAIL][/TD]
[TD]HI ALL[/TD]
[TD]C:\Users\gall\Desktop\Test\Neo James_analize test_201812.xlsx[/TD]
[/TR]
[TR]
[TD]anna@gmail.com[/TD]
[TD]cc@cc.com; [email]bb@bb.com[/EMAIL][/TD]
[TD]HI ALL[/TD]
[TD]C:\Users\gall\Desktop\Test\Anna Smith_today_201812.xlsx[/TD]
[/TR]
</tbody>[/TABLE]

Here is the macro:

Sub Sending_Mail()


Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range






With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set sh = Sheets("Munka1")




Set OutApp = CreateObject("Outlook.Application")


For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)




    Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")
    
    If cell.Value Like "?*@?*.?*" And _
    Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        
        With OutMail
            .to = sh.Cells(cell.Row, 1).Value
            .CC = sh.Cells(cell.Row, 2).Value
            .Subject = "HI all!!"         '<<<
           
            
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                                                                      
                    End If
                End If
                
            .Display
            Next FileCell
                                   
        End With
        
        Set OutMail = Nothing
    End If
Next cell


Set OutApp = Nothing


With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With






End Sub

How it is possible to send multiple attachment by ONE email?
For exemple do not send for Neo two emails with one-one attachment, send just ONE, with two attachment. I think I need DO - while command... Can you help me out?

Thanks for the answers!

 

[gallzsoltv]

Anyone?

 

[ayman helmy]

dd you get any notification ???

 

[Dev Rao]

Please update on the same.. what will code for send multiple attachments in one mail with path given in two or more column