• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to pdf a range and email it - modify Ron De Bruin code

E

Eric M

Member
Hello,

I would like to modify Ron De Bruin's mail code to make the attachment be a pdf instead of an excel attachment. http://www.rondebruin.nl/win/s1/outlook/amail8.htm this is the exact post of Ron's I got it from originally. I am also attaching a sample file of how the format of my report is, with all made up numbers of course.

What the macro currently does, is loop through Column A and filters onto a new workbook every row that has "USER1" in column A and attaches it to the email address specified in Column B. Every time the value changes in Column A, like from USER1 to USER2, a new workbook with that user's rows is created and attached to an email.

I would like the attachment to be a pdf and not in excel format. If it could keep the formatting from Excel at the same time that would be preferable.

Also, I have searched through old forum posts and while their are posts related to modifying Ron's mail code, he has many various codes for mailing, printing to pdf etc. and I am by no means a veteran VBA coder. I was thus unable to find the solution I desire with the aid of this forum's previous posts or Google's help.

Any help is appreciated!!

Code: 
Sub Send_Row_Or_Rows_Attachment_2()
  Dim OutApp As Object
  Dim OutMail As Object
  Dim rng As Range
  Dim Ash As Worksheet
  Dim Cws As Worksheet
  Dim Rcount As Long
  Dim Rnum As Long
  Dim FilterRange As Range
  Dim FieldNum As Integer
  Dim NewWB As Workbook
  Dim TempFilePath As String
  Dim TempFileName As String
  Dim FileExtStr As String
  Dim FileFormatNum As Long
  On Error GoTo cleanup
  Set OutApp = CreateObject("Outlook.Application")
  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
  'Set filter sheet, you can also use Sheets("MySheet")
  Set Ash = ActiveSheet
  'Set filter range and filter column (column with e-mail addresses)
  Set FilterRange = Ash.Range("A1:k" & Ash.Rows.Count)
  FieldNum = 2  'Filter column = B because the filter range start in column A
  'Add a worksheet for the unique list and copy the unique list in A1
  Set Cws = Worksheets.Add
  FilterRange.Columns(FieldNum).AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Cws.Range("A1"), _
  CriteriaRange:="", Unique:=True
  'Count of the unique values + the header cell
  Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
  'If there are unique values start the loop
  If Rcount >= 2 Then
  For Rnum = 2 To Rcount
  'If the unique value is a mail addres create a mail
  If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
  'Filter the FilterRange on the FieldNum column
  FilterRange.AutoFilter Field:=FieldNum, _
  Criteria1:=Cws.Cells(Rnum, 1).Value
  'Copy the visible data in a new workbook
  With Ash.AutoFilter.Range
  On Error Resume Next
  Set rng = .SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
  End With
  Set NewWB = Workbooks.Add(xlWBATWorksheet)
  rng.Copy
  With NewWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
  End With
  'Create a file name
  TempFilePath = Environ$("temp") & "\"
  TempFileName = "Budget Book - " & Ash.Parent.Name _
  & " " & Format(Now, "dd-mmm-yy h-mm-ss")
  If Val(Application.Version) < 12 Then
  'You use Excel 97-2003
  FileExtStr = ".xls": FileFormatNum = -4143
  Else
  'You use Excel 2007-2013
  FileExtStr = ".xlsx": FileFormatNum = 51
  End If
  'Save, Mail, Close and Delete the file
  Set OutMail = OutApp.CreateItem(0)
  With NewWB
  .SaveAs TempFilePath & TempFileName _
  & FileExtStr, FileFormat:=FileFormatNum
  On Error Resume Next
  With OutMail
  .to = Cws.Cells(Rnum, 1).Value
  .Subject = "Quarterly Budget Report"
  .Attachments.Add NewWB.FullName
  .Body = "Body of email"
  .Display  'Or use Send
  End With
  On Error GoTo 0
  .Close savechanges:=False
  End With
  Set OutMail = Nothing
  'Kill TempFilePath & TempFileName & FileExtStr
  End If
  'Close AutoFilter
  Ash.AutoFilterMode = False
  Next Rnum
  End If
cleanup:
  Set OutApp = Nothing
  Application.DisplayAlerts = False
  Cws.Delete
  Application.DisplayAlerts = True
  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
End Sub
 

Attachments

Also, it may be worth adding. Ron has several macro's that print to pdf and attach it to an email. He has one that prints every tab in a workbook if it has an email address in A1 for example. This is a Macro I have used in the past with success. The format of this report, with each Division being on one tab is not a format that I was able to find a macro for that would both print to pdf and attach to an email. It may be worth checking out the link I posted above if you are better with VBA than I am. I have been trying to add code to the code above to get it to print to pdf and it always just errors out :(
 
Try this:

Code: 
Option Explicit

Sub Send_Row_Or_Rows_Attachment_2()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim TempFilePath As String
Dim TempFileName As String


On Error GoTo cleanup

Set OutApp = CreateObject("Outlook.Application")

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:k" & Ash.Rows.Count)
FieldNum = 2  'Filter column = B because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add

FilterRange.Columns(FieldNum).AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Cws.Range("A1"), _
  CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
  For Rnum = 2 To Rcount
    'If the unique value is a mail addres create a mail
    If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
     
      'Filter the FilterRange on the FieldNum column
      FilterRange.AutoFilter Field:=FieldNum, Criteria1:=Cws.Cells(Rnum, 1).Value
     
      'Copy the visible data in a new workbook
      With Ash.AutoFilter.Range
        On Error Resume Next
        Set rng = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
      End With
     
      'Set print area
      ActiveSheet.PageSetup.PrintArea = rng.Address
      Application.PrintCommunication = False
      With Ash.PageSetup
          .Orientation = xlLandscape
          .FitToPagesWide = 1
          .FitToPagesTall = 1
      End With
      Application.PrintCommunication = True
     
     
      'Create a file name
      TempFilePath = Environ$("temp") & "\"
      TempFileName = TempFilePath & "Budget Book - " & Ash.Parent.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"
     
      'Export to pdf file
      Ash.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFileName, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
     
      'Save, Mail, Close and Delete the file
      Set OutMail = OutApp.CreateItem(0)
     
        On Error Resume Next
          With OutMail
            .To = Cws.Cells(Rnum, 1).Value
            .Subject = "Quarterly Budget Report"
            .Attachments.Add TempFileName
            .Body = "Body of email"
            .Display  'Or use Send
          End With
        On Error GoTo 0
     
      Set OutMail = Nothing

    End If
   
    'Close AutoFilter
    Ash.AutoFilterMode = False
  Next Rnum
End If

cleanup:
  Set OutApp = Nothing
  Application.DisplayAlerts = False
  Cws.Delete
  Application.DisplayAlerts = True

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

End Sub
 
Peter,

Thanks for posting. Your macro is closer than I ever got, however there are 2 problems. When it prints each PDF file is 34 pages long (the total # of pages in my actual report). Each page will print blank except for the page that the filtered report was on. So if Dept X was on page 18, every page but 18 will be blank.

It also doesn't print title's. I'm playing around with the macro, haven't had any luck yet.

Thanks for the help!
 
Hi Eric,

Please see the updated file.

The code does the following:
  • Sorts the data by User name (this is needed)
  • Applies the filter (to just show one user)
  • Sets the print area so for just the filtered range
  • Exports to Pdf for just that filtered range
  • Row headings are repeated at the top of each page

If you want to include a title then (In Excel 2013), go to:
  • Page Layout
  • Page Setup
  • Left mouse click in the bottom right hand corner of that range of icons
  • Header / Footer
  • Custom Header

Thanks,

Peter
 

Attachments

Peter, I got that to work but I think it kind of defeats the purpose if I have to filter for each user, reset the print area and run the macro for every department. There are over 30 of them.
 
Hi Eric,

I think you have mis understood the code. You do not have to
"filter for each user, reset the print area and run the macro for every department"
Click to expand...
The vba does all of that for you. If you run the code in the workbook that I uploaded to the previous post you will see it doing all of that.

Thanks,

Peter
 
Alright Peter, perhaps I did. I will check it out again on Monday. Away from a computer for the weekend. I'll let you know!
 
Peter, I tried running the code on the sample file you attached. When I run it I can see the screen updating bring up the list of unique email addresses (3 in the sample file), but it only loops and creates the pdf/mail for user1@email.com. Then it stops, not looping through user2 and user3 even though they are on the unique email list that is created in the macro.

Sorry for being such a pain, the help is very much appreciated though :)

Eric
 
Hi Eric,

My apologies. SirJB is correct. I accidentally uploaded the workbook with the test version of the code, while posting the correct version in the comment.

If you make the change as suggested, it should work as you require.

Kind regards,

Peter
 
Hi,

I got it to work on the sample file, printing all users to pdf and attaching them to an email. It was exactly how I had hoped. However, in transferring the macro to my actual workbook I get the error below:

---------------------------
Microsoft Visual Basic for Applications
---------------------------
Object variable or With block variable not set
---------------------------
OK Help
---------------------------

If you click help it takes you here for more info http://msdn.microsoft.com/en-us/library/office/gg264837(v=office.15).aspx
 
Hi Eric,

When that error message appears, please can you click on the [Debug] button and it will take you to the code. Please can you then copy and paste the highlighted line of code in a comment on here so I can see where it is breaking?

Regards,

Peter
 
Hi Eric ,

I have not gone through anything in this thread in detail ; what I did was download Peter's file , and run the macro ; I did not get the error you mention.

However , if you can troubleshoot the error , what you can do is put a breakpoint at the following line in the macro :

Cws.Delete

To set a breakpoint , place the cursor on that line and press F9.

Now , run the macro ; when program execution comes to the line which has the breakpoint , it will halt ; go to the workbook , and check whether the new sheet which was added is still available.

Place the cursor in the Immediate window , and type in :

?Cws.Name

Do you get the name of the added sheet displayed ? For example , if the added sheet was Sheet4 , you should see Sheet4 displayed at this stage.

Can you try this out and post back ?

Narayan
 
Narayan,
I went to Cws.Delete and entered a breakpoint with F9. I then tried running the Macro and just got the same error as before. Hitting Debug still brings me to the Cws.Delete line.

No window popped up and no worksheet generated.
 
Hello,

I realize it has been a few weeks but I got the macro working on my production worksheet.
Thank you to everyone that helped, particularly PeterB. Your code was immaculate.

Turns out the problem was simple, my production workbook was a pivot table and the testing worksheet I uploaded here was values. So all I had to do was paste the pivot table values to a new worksheet and the macro worked flawlessly.


Thanks a lot!


Edit: How do I mark this as [Solved] ?? Or does a moderator have to do that?
 
Last edited:
Hi there,

Thank you so much for sharing this, it literally changed my life and made my customers so happy. But .. once you give people something they typically want more.

Can anyone tell me how to modify this so that the data exports to Excel attachments and not PDF?

Thanks,
Brett
 
MM...i think i gotcha bud. Ill try to upload it tomorrow night as my copy is at work and unfortunately forums are blocked -_-

Awesome that you were able to work through it from this post, I have like 5 different versions of this macro doing different routines depending on the need, maybe i'll gather them up and post them all!
 
Sorry it took me a few days, below should work for you though. I use it frequently :)

Code: 
Sub Send_Row_Or_Rows_Attachment_2()
 
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim NewWB As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
 
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet
 
    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:r" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A
 
    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True
 
    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
 
    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount
 
            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
 
                'Filter the FilterRange on the FieldNum column
                FilterRange.AutoFilter Field:=FieldNum, _
                                      Criteria1:=Cws.Cells(Rnum, 1).Value
 
                'Copy the visible data in a new workbook
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With
 
                Set NewWB = Workbooks.Add(xlWBATWorksheet)
 
                rng.Copy
                With NewWB.Sheets(1)
                    .Cells(1).PasteSpecial Paste:=8
                    .Cells(1).PasteSpecial Paste:=xlPasteValues
                    .Cells(1).PasteSpecial Paste:=xlPasteFormats
                    .Cells(1).Select
                    Application.CutCopyMode = False
                End With
 
                'Create a file name
                TempFilePath = Environ$("temp") & "\"
                TempFileName = "Scrubbing Report - " & Ash.Parent.Name _
                            & " " & Cws.Range("k2") & " " & Format(Now, "dd-mmm-yy h-mm-ssss")
 
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2013
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
 
                'Save, Mail, Close and Delete the file
                Set OutMail = OutApp.CreateItem(0)
 
                With NewWB
                    .SaveAs TempFilePath & TempFileName _
                          & FileExtStr, FileFormat:=FileFormatNum
                    On Error Resume Next
                    With OutMail
                        .To = Cws.Cells(Rnum, 1).Value
                        .Subject = "subject here"
                        .Attachments.Add NewWB.FullName
                        .Body = "body of email here"
                        .display  ' use .Send to send emails automatically or .Display to preview them before sending
                    End With
                    On Error GoTo 0
                    .Close savechanges:=False
                End With
 
                Set OutMail = Nothing
                'Kill TempFilePath & TempFileName & FileExtStr
            End If
 
            'Close AutoFilter
            Ash.AutoFilterMode = False
          
            Application.Wait (Now + TimeValue("0:00:01"))
            'Buff the time between loops so it doesn't prompt you to replace files
          
        Next Rnum
    End If
 
cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 
Thanks Eric. Much appreciated. I'm at home sick today but will try it when I'm back at work and let you know how I get on =)
 
I only registered here to say thank you to PeterB for this kickass macro. I spent 3 days looking for different macros that would sort, filter and export the filtered results to PDF until I found this thread. You have no idea how many hours of my month you saved with this code. Cheers!
 
You must log in or register to reply here.
Back
Top