[RESOLVED] Attach multiple reports to recipients in one email

[fusion001]

Hi..I have the code below to email out reports to users. Some users could have multiple reports which are listed in column A in each cell. So if one user has say 10 reports it is sending them 10 emails. I would like to send one email with the 10 attachments. Can someone please advise what I need to change or add to the code. Thanks

Sub Email()


mypath = "C:\Reports\"
Set oboutlook = CreateObject("outlook.application")
For Each cel In Range("a2:a500")
If IsEmpty(cel) Then Exit For    
  Set nm = oboutlook.CreateItem(0)  ' new mail item
  With nm
    .To = cel.Offset(, 1) 
    .Attachments.Add mypath & cel & ".xlsx"
    
    .Body = "Please find attached reports" 
    .Subject = "Reports"
    .Save
    .Send
'    .Close
  End With
Next


End Sub

[westconn1]

there could be several approaches to this

assuming the email addresses are in column b, you could sort or filter by email address from that column, you could test manually with your workbook to see if you can get appropriately filtered lists

personally i would prefer to use ADO, with SQL to generate a recordset from the worksheet, of unique users (email addresses) then loop that recordset to generate a second recordset for each user, in turn, with all their attachments to email

[fusion001]

personally i would prefer to use ADO, with SQL to generate a recordset from the worksheet, of unique users (email addresses) then loop that recordset to generate a second recordset for each user, in turn, with all their attachments to email

Hi Pete...can you please help me with the code for this. I don't really want to be touching the email address file as it could change frequently.

[fusion001]

Sorted thanks.

[westconn1]

Sorted thanks.

pls post your solution to assist others who find this tread

[fusion001]

This is the code

Sub email()
Dim sht As Worksheet
Dim myfiles() As String

Set sht = Sheets("sheet1")     ' change to suit
sht.UsedRange.Sort sht.Range("b:b"), , , , , , , xlNo ' xlyes for header row, if you do not have header row change to xlno
myfilepath = "c:\Reports\"


Set myOutlook = GetObject(, "Outlook.Application")
Set myMessage = myOutlook.CreateItem(0)
rw = 0    ' change to 1 if you want to have a header row
Do Until IsEmpty(sht.Cells(rw + 1, 2))
rw = rw + 1
      With myMessage

        
        .To = sht.Cells(rw, 2)
        .Subject = "Reports"
        '.BodyFormat = olFormatHTML
        .body = "Please find attached reports"



        myfiles = Split(Sheets("sheet1").Cells(rw, 1), ";")

        For a = 0 To UBound(myfiles)
           ext = ".xlsx"
   
            .Attachments.Add myfilepath & myfiles(a) & ext
   
        Next
        If Not sht.Cells(rw, 2) = sht.Cells(rw + 1, 2) Then
        
         .send
         Set myMessage = myOutlook.CreateItem(0)
        End If
       
    End With

Loop




End Sub

Code worked fine but one issue I have is that if if on the distribution list there is a report which doesn't exist in the folder I get a debug saying file or path doesn't exist. What code do I need to add to skip any reports not found in the folder? Also it would be useful if we can get an exceptions list of those reports not found if it is an easy set up. Thanks

[westconn1]

        For a = 0 To UBound(myfiles)
           ext = ".xlsx"
           if len(dir(myfilepath & myfiles(a) & ext)) > 0 then
              .Attachments.Add myfilepath & myfiles(a) & ext
              else 
              errlist = errlist & .to  & " - " & myfilepath & myfiles(a) & ext & vbnewline
          end if
        Next

of course if there is only one attachment and the file is missing then an email without attachments will be sent,
before end sub you can have a msgbox or write to file errlist so you can see which reports were not found,

[fusion001]

Thanks Pete. There may be recipients who will receive multiple reports so they should get all the reports even if there are some reports missing however if there is only one report for a recipient and the report is missing then I don't want an email to be sent for that recipient. The code should just skip to the next recipient.

[westconn1]

that would need a rewrite of the code to change the order things are done, some stuff should be changed anyway, i will look later

[westconn1]

Set sht = Sheets("sheet1")     ' change to suit
sht.UsedRange.Sort sht.Range("b:b"), , , , , , , xlNo ' xlyes for header row, if you do not have header row change to xlno
myfilepath = "c:\Reports\"
Set myOutlook = GetObject(, "Outlook.Application")
  ext = ".xlsx"
rw = 0    ' change to 1 if you want to have a header row
Do Until IsEmpty(sht.Cells(rw + 1, 2))
    myfiles = Split(Sheets("sheet1").Cells(rw, 1), ";")
    fnd = False
    For a = 0 To UBound(myfiles)
      If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
        fnd = True: Exit For '    some valid report path found
      End If
    Next
    If fnd Then
        rw = rw + 1
        If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
           Set myMessage = myOutlook.CreateItem(0)
            With myMessage
              .To = sht.Cells(rw, 2)
              .Subject = "Reports"
               .body = "Please find attached reports"
              For a = 0 To UBound(myfiles)
                 If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
                    .Attachments.Add myfilepath & myfiles(a) & ext
                    Else
                    errlist = errlist & .To & " - " & myfilepath & myfiles(a) & ext & vbNewLine
                End If
              Next
              .send
          End With
        End If
        Else
        errlist = errlist & "no valid report found for " & Cells(rw, 2)
    End If
Loop

i have not really changed what it does, just changed the order it does things, i have not tested at all, this now checks each email to see if there is any valid report path at all and checks each report path to see if it is valid

[fusion001]

Thanks for that Pete. I get an "Application-defined or object-defined error" on

 myfiles = Split(Sheets("sheet1").Cells(rw, 1), ";")

.

[westconn1]

i made a couple of minor changes

Set sht = Sheets("sheet1")     ' change to suit
sht.UsedRange.Sort sht.Range("b:b"), , , , , , , xlNo ' xlyes for header row, if you do not have header row change to xlno
myfilepath = "c:\Reports\"
Set myOutlook = GetObject(, "Outlook.Application")
  ext = ".xlsx"
rw = 1    ' change to 2 if you want to have a header row
Do Until IsEmpty(sht.Cells(rw, 2))
    myfiles = Split(Sheets("sheet1").Cells(rw, 1), ";")
    fnd = False
    For a = 0 To UBound(myfiles)
      If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
        fnd = True: Exit For '    some valid report path found
      End If
    Next
    If fnd Then
        If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
           Set myMessage = myOutlook.CreateItem(0)
            With myMessage
              .To = sht.Cells(rw, 2)
              .Subject = "Reports"
               .body = "Please find attached reports"
              For a = 0 To UBound(myfiles)
                 If Len(Dir(myfilepath & myfiles(a) & ext)) > 0 Then
                    .Attachments.Add myfilepath & myfiles(a) & ext
                    Else
                    errlist = errlist & .To & " - " & myfilepath & myfiles(a) & ext & vbNewLine
                End If
              Next
              .send
          End With
        End If
        Else
        errlist = errlist & "no valid report found for " & Cells(rw, 2)
    End If
    rw = rw + 1
Loop

[fusion001]

Hi Pete...multiple emails with individual reports are now being generated rather than just one email per recipient. Also the error list is not being generated.

[westconn1]

post a sample workbook, as i was only working with the code as provided in post #6 and assumed that the data matched what the code was doing

[fusion001]

Hi Pete...in the workbook all I have is in column A is the report name and in column B is the email address.
i used the code in post #12

For example


1234 FB@g.com
2345 FB@g.com
7777 TT@h.com
1111 FB@g.com

[westconn1]

ok, i can see why there is the problem

myfiles = Split(Sheets("sheet1").Cells(rw, 1), ";")

this line indicated that all reports were in on cell, separated by ;

sht.UsedRange.Sort sht.Range("b:b"), , , , , , , xlNo ' xlyes for header row, if you do not have header row change to xlno

this line, looks like something i have posted previously, was to sort the email addresses, which you indicated in post #3 you did not want to do
though you could save the workbook then run the code and close without saving

you can test this, i did not get time to test

Dim sht As Worksheet
Dim myfiles() As String

Set sht = Sheets("sheet1")     ' change to suit
sht.UsedRange.Sort sht.Range("b:b"), , , , , , , xlNo ' xlyes for header row, if you do not have header row change to xlno
myfilepath = "c:\Reports\"
ext = ".xlsx"
Set myOutlook = GetObject(, "Outlook.Application")
Set myMessage = myOutlook.CreateItem(0)
rw = 0    ' change to 1 if you want to have a header row
Do Until IsEmpty(sht.Cells(rw + 1, 2))
rw = rw + 1
      With myMessage
        .To = sht.Cells(rw, 2)
        .Subject = "Reports"
        .body = "Please find attached reports"
        If Len(Dir(myfilepath & sht.Cells(rw, 1) & ext)) > 0 Then
            .attachments.Add myfilepath & sht.Cells(rw, 1) & ext
            Else
            errlist = errlist & "Path does not exist to " & Cells(rw, 1) & " for " & Cells(rw, 2)
        End If

        If Not sht.Cells(rw, 2) = sht.Cells(rw + 1, 2) Then
            If .attachments.Count > 0 Then
            .send
            Else
            errlist = errlist & "No valid reports found for " & Cells(rw, 2)
            .Close 1   ' discard mail item
        End If
         Set myMessage = myOutlook.CreateItem(0)
        End If
       
    End With
Loop

i am sure this is some code a wrote a while ago, just with checking for file validity added

if i was going to redo it, i would use ADO

[fusion001]

Hi Pete...only one email is sent per recipient which is great but the error messages are not generated.

[westconn1]

did you check if errlist variable contains any value?

msgbox errlist

before end sub

[fusion001]

That's perfect. Thanks very much.

[fusion001]

I have one question which is not really directly related to this thread but is linked. I have a added a variable to the email subject so the user can add the subject title each month.
I have added another piece of code which is called by the main sub above to let a group of people know that the reports have been emailed out. Is there a way to link the email subject title to the variable in the first code?
Thanks

[westconn1]

Is there a way to link the email subject title to the variable in the first code?

of course

you could use an inputbox

monthtitle = InputBox("Enter a title for email cubject")

change the subject line to suit

.subject = "Reports for " & monthtitle

[fusion001]

Is it not possible to use the subject title from the first set of code rather than have to create another input box for the email notification?

[westconn1]

Is it not possible to use the subject title

probably,

so the user can add the subject title each month.

but i thought you wanted the user to put additional information on a month to month basis, an inputbox seemed preferable to having the user change the code, or you had some other idea?

[fusion001]

Hi Pete...sorry for the confusion. What I have done is added an input box in the main code post #16.
Then I have added another sub to email out specific people to notify that the reports have been emailed from the first set of code. So rather than have another input box for this second part of the code is there a way to pick up the subject from the first code? I hope this makes sense.

[westconn1]

you can pass the variable to the second sub as parameter when you call it
something like

sub second(subject as string)

[fusion001]

Sorted. Thanks.
Added

Public varfolder2 As String

[fusion001]

Hi..rather than start a new thread I thought I'd add to this one. The above code works perfectly but what I need to do is attach a word document to the emails. The issue I have is that if an email recipient has say 10 reports it is adding the word document 10 times rather than just the once. I just want one word document per email plus all the other reports. Can anyone help with this please?

.Attachments.Add myfilepath & "Letter.docx"

[westconn1]

        If Not sht.Cells(rw, 2) = sht.Cells(rw + 1, 2) Then
   ' i reckon you would have to add it here
            If .attachments.Count > 0 Then
   ' or here, depending on your requiremens
            .send
            Else
            errlist = errlist & "No valid reports found for " & Cells(rw, 2)
            .Close 1   ' discard mail item
        End If

[fusion001]

Hi...Thanks so much for that