Email individual attachments

Metin81

New Member
Joined
Jun 21, 2018
Messages
2
Hi, I am new on the form and not very familiar with Macro's.
I found the following macro on the web.

Sub SendEmailfromOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Path As String
Path = Application.ActiveWorkbook.Path
Set OutApp = CreateObject("Outlook.Application")

For Each cell In Range("C3:C10")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = Cells(cell.Row, "D").Value
.Body = "Dear " & Cells(cell.Row, "B").Value & "," _
& vbNewLine & vbNewLine & _
"Please find attached a list of overdue invoices. Thank you!"
.Attachments.Add (Path & "" & Cells(cell.Row, "D").Value)
.Attachments.Add (Path & "" & Cells(cell.Row, "E").Value)
.Attachments.Add (Path & "" & Cells(cell.Row, "F").Value)
'.Send

.Save
End With
Next cell
End Sub

With this macro I want to send overdue invoices to customers, some customers have more then one overdue invoice which I want to attach in the same email. My question is how I can make sure I got no error with this code when a customer has only one invoice, which means cell E and F is blank.
So if client A has 3 overdue invoice the macro workd fine, but if the macro continue to client B which has only one overdue invoice it stop working and it won't work on client C D E ...

Hope it's clear.
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
How about this...

Code:
Sub SendEmailfromOutlook()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C10")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub
 
Upvote 0
Thank you igold, what happens is that the macro runs the code on row 3 and give an error, it won't row 4. Attached a screenshot of my excel sheet, I don't know how to add the spreadsheet itself.

Thanks!!

Oustanding balance
Name ClientEmail ClientAttachment name
JohnJohn@hotmail.comInv 1.pdfInv 2.pdfInv 3.pdf
EvaEva@hotmail.comInv 4.pdf
AdamAdam@hotmail.comInv 5.pdfInv 6.pdf

<colgroup><col><col><col><col span="2"><col></colgroup><tbody>
</tbody>
 
Upvote 0
One thing I noticed is that you are missing a backslash. I did not know if you had it attached in the cell. for example in line 3 the attachment name would be this: \Inv 1.pdf

The better way would be in the code itself like this: I tested this code with your information from post #3 and it works fine for me but breaks at the last line where there is no more data. However the emails were created and saved in my drafts. If you don't have information from C3:C10 the code will break at the first blank line.

Code:
Sub SendEmailfromOutlook()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C10")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub
 
Last edited:
Upvote 0
This would be prevent the breaks caused by the blank rows...

Code:
Sub SendEmailfromOutlook()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    Dim lRow As Long
    
    lRow = Range("C3").End(xlDown).Row
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C" & lRow)
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "\" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "\" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "\" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top