Help! VBA Email Loop

[DMan_II]

Hello,

Very first post! To start off I am very bad at coding, in the past I always just try to find what I'm looking for posted somewhere then alter the code or add things together to make it work. This one has me stumped and I cant get it to work the way I want it, which is why I finally caved in and joined here (always seems to have the best answers).

Data and what I'm doing:

I download a large credit card data file that I then format and send individual pieces to the employees to submit an expense report. It takes way too long. I already created a macro that breaks down the data into individual worksheets for each person and includes a total. Now what I want to do is email that specific worksheet data pasted into the email body to the corresponding person. The macro I altered below works, but only on the whatever worksheet is active and I cannot get it to cycle/loop through all the worksheets. P.S. I am using Outlook.

Each worksheet looks like so:

Name		TRANS DATE		DESCRIPTION	AMOUNT
DOE, JOHN D	test@text.co	6/1/2015	DEBIT	UNITED	-882.2
DOE, JOHN D	test@text.co	6/2/2015	DEBIT	HILTON HOTEL	-50
DOE, JOHN D	test@text.co	6/3/2015	DEBIT	UBER	-18.63
DOE, JOHN D	test@text.co	6/4/2015	DEBIT	UBER	-16.49
DOE, JOHN D	test@text.co	6/5/2015	DEBIT	GAS	-15.5
DOE, JOHN D	test@text.co	6/6/2015	DEBIT	DNC TRAVEL	-14.33
DOE, JOHN D	test@text.co	6/8/2015	DEBIT	MCDONALD'S	-11.45
DOE, JOHN D	test@text.co	6/9/2015	DEBIT	ANNUAL MEMBERSHIP FEE	-10
DOE, JOHN D	test@text.co	6/12/2015	DEBIT	FROZEN YOGURT	-3.24
DOE, JOHN D	test@text.co	6/13/2015	CREDIT	REVERSAL OF ANNUAL MEMBERSHIP FEE	10
				Total	-1011.84

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

My current code:

Sub Send_Range()

ActiveSheet.Range("F1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range(Selection, Selection.End(xlToLeft)).Select
ActiveSheet.Range(Selection, Selection.End(xlToLeft)).Select


ActiveWorkbook.EnvelopeVisible = True


With ActiveSheet.MailEnvelope
.Introduction = "Below is all the transactional data from your credit card from 6/1/15 to 6/30/15."
.Item.To = ActiveSheet.Range("B2")
.Item.Subject = "June 2015 Expense Report"
.Item.Send

End With
End Sub

 

[RickXL]

Hi and welcome to the MrExcel Message Board.

I had never used EnvelopeVisible before but as far as I can see it does not allow you to select a different worksheet without activating it first.

I had several goes at making it work so I hope I have not changed your code beyond all recognition in the process.

I also pinched some ideas from RondeBruin along the way. See the link in the code.

Anyway, I think this works. It loops round each worksheet and activates it. Then it fills in the details and sends the email.

' http://www.rondebruin.nl/win/s1/outlook/bmail3.htm
Sub Send_Range()

    Dim ws As Worksheet
    Dim rngMail As Range
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            .Activate
            Set rngMail = .Range(.Range("A1"), .Range("F1").End(xlDown))
            With rngMail
                ThisWorkbook.EnvelopeVisible = True
                With .Parent.MailEnvelope
                    .Introduction = "Below is all the transactional data from your credit card from 6/1/15 to 6/30/15."
                    With .Item
                        .To = ws.Range("B2").Value
                        .Subject = "June 2015 Expense Report " & ws.Name
                        .Send
                    End With
                End With
            End With
        End With
    Next
End Sub

 

[DMan_II]

WOW!!! That's is so awesome I cannot thank you enough! This will save me so much time!!!

I have one last question, how do I add an attachment to each email? I would like to send the email with our expense report sheet as well as our expense policy.

RickXL is the man!!!

 

[RickXL]

Hi,

This seems to work:

' http://www.rondebruin.nl/win/s1/outlook/bmail3.htm
Sub Send_Range()

    Dim ws As Worksheet
    Dim rngMail As Range
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            .Activate
            Set rngMail = .Range(.Range("A1"), .Range("F1").End(xlDown))
            With rngMail
                ThisWorkbook.EnvelopeVisible = True
                With .Parent.MailEnvelope
                    .Introduction = "Below is all the transactional data from your credit card from 6/1/15 to 6/30/15."
                    With .Item
                        .To = ws.Range("B2").Value
                        .Subject = "June 2015 Expense Report " & ws.Name
                        .Attachments.Add ThisWorkbook.Path & "\A.xlsx"
                        .Send
                    End With
                End With
            End With
        End With
    Next
End Sub

Note, you can change the path and filename to be what you want, I just happened to have a small file called A.xlsx in the same folder as my worksheet. So it was convenient for testing.

 

[DMan_II]

Thanks Rick!

It seems the only way I can attach a file is if it's in the same folder (which I don't mind doing) but when I use a file path to a mapped drive (M:\AP\4-BANKCARD\FY 2016\Expense Reports Detail.xlsm) it says "cannot locate file." The other issue is with each subsequent email it adds another attachment (first email send one, second email send two, third sends three, etc.) which could get crazy when I send out approximately 80. This quote from another site was an answer to solve that exact issue but I couldn't get code to clear attachments to work:

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, 'Lucida Console', 'Liberation Mono', 'DejaVu Sans Mono', 'Bitstream Vera Sans Mono', 'Courier New', monospace, sans-serif; white-space: inherit;">Sub Send_Range()
Dim x AsInteger
Dim i AsInteger

x = Sheets("MarketMacro").Range("M1").Text 'A count of how many emails to send.
i =2

Do
' Select the range of cells on the active worksheet.
Sheets("Summary").Range("A1:M77").Select
' Show the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible =True

With ActiveSheet.MailEnvelope
'Before we send emails, we will loop through the Attachments collection
'and delete any that are in there already.
'There seemed to be an issue with the For...Each construct which
'would not delete all the attachments. This is the only way I could
'do it.
DoUntil.Item.attachments.Count =0
.Item.attachments(1).Delete
Loop

.Introduction ="This is a sample worksheet."
.Item.To= Sheets("MarketMacro").Range("A"& i).Text
.Item.Subject ="Test"'email subject
.Item.attachments.Add (Sheets("MarketMacro").Range("H"& i).Text)'add attachment based on path in worksheet cell
.Item.Send 'sends without displaying the email
EndWith
i = i +1
LoopUntil i = x +2
MsgBox ("The tool sent "& i -2&" reports.")
EndSub</code>I believe the code is just reusing the same MailEnvelope object, overwriting each property each time you enter your Do...Until loop. But since Attachments is a collection and not a scalar, you are appending one additional item every time you go through the loop. I've added a small loop within that outer loop that will search through .Item.Attachments and delete each attachment while .Attachments.Count is greater than 0. That way, it should always be a blank slate when it comes time to send the mail.

 

[RickXL]

Hi,

It works for me.

I did have a problem when I could not debug it properly but that is not there any more. So something is a bit flaky.
You cannot Display the email prior to sending it. That causes problems. I think you can save the emails though.

I tried it with another filename and that seems to be working as well.

After a lot of experimenting I have some of the statements in a slightly different place but it is largely unchanged.

The reason you attachments kept adding up was because when the macro was going round the loop it was not initialising a new mail item. So the attachments were added to. If you use Outlook in another way, e.g. by transforming your worksheets into html and not using EnvelopeVisible at all, it still does that if you are still using the same mail item on subsequent loops.

This is how it ended up:

Sub Send_Range()

    Dim ws As Worksheet
    Dim rngMail As Range
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            .Activate
            ThisWorkbook.EnvelopeVisible = True
            Set rngMail = .Range(.Range("A1"), .Range("F1").End(xlDown))
            With rngMail
                ThisWorkbook.EnvelopeVisible = True
                With ws.MailEnvelope
                    .Introduction = "Below is all the transactional data from your credit card from 6/1/15 to 6/30/15."
                    With .Item
                        .To = ws.Range("B2").Value
                        .Subject = "June 2015 Expense Report"
                        .Attachments.Add "C:\InputBin.txt"
                        .Send
                    End With
                End With
            End With
        End With
    Next
End Sub

 

[DMan_II]

Thanks Rick, I got the attachments to work but it was still reattaching each successive email. I searched and found a code (in bold & underlined below) and just plugged it in and it works fine now. Apparently it loops backwards when deleting. Thanks again Rick this really will same me lots of tedious hours!!!

Sub Send_Range()


    Dim ws As Worksheet
    Dim rngMail As Range
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            .Activate
            ThisWorkbook.EnvelopeVisible = True
            Set rngMail = .Range(.Range("A1"), .Range("F1").End(xlDown))
            With rngMail
                ThisWorkbook.EnvelopeVisible = True
                With ws.MailEnvelope


For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
                    .Introduction = "Below is all the transactional data from your credit card from 6/1/15 to 6/30/15."
                    With .Item
                        .to = ws.Range("B2").Value
                        .Subject = "June 2015 Expense Report"
                        .Attachments.Add "file.doc"
                        .Attachments.Add "file2.doc"
                        .Send
                    End With
                End With
            End With
        End With
    Next
End Sub

 

[RickXL]

Hi,

I have seen people mention problems if the versions of Outlook and Excel don't match. I am using Office 2013 perhaps you are using a different version?

Also, the deleting backwards thing. If you have four things in a list and you do a "For i = 1 to 4" it will fail because after the first delete there are only three things in the list. There is no longer an item 4 but you will try to delete one at some point. So f you keep removing the first item until there are no more then it will always work.

I tried to send worksheet contents without using EnvelopeVisible and MailEnvelope. I ended up converting the columns into html which was a bit tedious. However, the first time I did it it kept adding more attachments. It happens if you use the same mailitem all the time. The way you are doing it, there is some sort of connection between EnvelopeVisible and the Send command. One seems to create an item and the other clears it. That, it seems, is the bit that is not working for you.

Anyway, I am pleased we have got a solution - thanks for confirming.

Regards,