Excel to send worksheets as PDF based on info in 1st worksheet

Hi

I have an excel file which has several sheets within it. The first sheet is the contact sheet. The last sheet is my data sheet and all the sheets in between are the reports that I need to email every month. The common value in each of these sheets is the store# (1001 - 1005 in the attached excel example). You will see this code used in sheet one along with email addresses.

The store number is hidden in cells A6 on all the report sheets as the number was needed to do a Vlookup using the data sheet.

Now, what I would like is perhaps a button that I can press which will automatically email each report sheet to the corresponding email in the Contacts sheet. As some do not have an email, only a fax number, I also need the macro to skip over that document as I will need to print it and fax it manually.

Is this possible?

NB: the attached is an small example as there is confidential info in there. I will have about 50 report sheets in the real thing.

Thanks!

Linda

Statement of Monthly Turnover EXAMPLE.xlsx

Hi Linda

Welcome to the Forum!

This Code is in the attached and appears to do as you require...let me know of issues.

Option Explicit
Dim myStore As String
Dim ws As Worksheet
Dim rng As Range

Sub test()
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "CONTACTS" And ws.Name <> "DATA" Then
            With ws
                myStore = .Range("A6")

                With Sheets("CONTACTS").Range("A:A")
                    Set rng = .Find(What:=myStore, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                    If Not rng Is Nothing Then
                        If rng.Offset(0, 3).Value Like "?*@?*.?*" Then
                            Call Create_PDF
                        Else
                            GoTo SkipMe
                        End If
                    End If
                End With
            End With
        End If
SkipMe:
    Next ws
End Sub

Sub Create_PDF()
    Dim strSubject As String
    Dim strBody As String
    Dim strTo As String
    Dim strCC As String
    Dim Filename As String
    Dim myPath As String


    myPath = ThisWorkbook.Path & "\"
    strSubject = "Enter Your Subject Here"  '<----------------
    strBody = "Enter Your Body Message Here"  '<----------------
    strTo = rng.Offset(0, 3).Value
    strCC = ""

    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            myPath & myStore & ".pdf" _
            , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
    Filename = myPath & myStore & ".pdf"

    If Filename <> "" Then
        RDB_Mail_PDF_Outlook Filename, strTo, strCC, strSubject, strBody, False '<---Change to True to Auto Send Mail
    Else
        MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                "Microsoft Add-in is not installed" & vbNewLine & _
                "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                "You didn't want to overwrite the existing PDF if it exist"
    End If
    Kill Filename
End Sub


Function RDB_Mail_PDF_Outlook(FileNamePDF As String, strTo As String, strCC As String, _
        strSubject As String, strBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = strTo
        .CC = strCC
        .BCC = ""
        .Subject = strSubject
        .Body = strBody
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Hi Linda

This error would indicate you have 2 (or more) Option Explicit statements...get rid of all except the uppermost

it comes up with error: "Invalid Inside Procedure"

Make certain the remaining statement is the first line of Code.

Regarding this

excel automatically adds the line "Sub Email_Form()"

When you create the Button, create a Forms Control Button and assign the Macro test to that Button.

Hi Linda

Post the offending Workbook...I'll demonstrate what you need to do...this line does not belong in the Code.

Sub Email_Form()

Hi Linda

I'm not sure what you did to get this line of Code into the Code

'Sub Email_Form()

As you can see I've simply eliminated (commented out) that line of Code then, with Email Form Button I've assigned Macro "test" to that Button. To assign Code to the Email Form Button, right click on the Button ---> Assign Macro ----> Select "test" ----> OK.

Works for me...does it work for you?

Hi Linda...yes...these are both possible. To Send the Email change this line of Code

 RDB_Mail_PDF_Outlook Filename, strTo, strCC, strSubject, strBody, False '<---Change to True to Auto Send Mail

Regarding the Signature...that'll have to wait until tomorrow...have Grandson Duty in the AM and am off to bed.

Hi Linda

To insert your Signature into the Emails replace your ENTIRE Code with this Code. You'll need to modify this line to the name of your Signature

SigString = Environ("appdata") & _
            "\Microsoft\Signatures\jas.txt" '<---Modify jas.txt to the name of your Signature

This change may or may not work depending on your operating system and what version of Outlook your using. I'm running XP with Outlook 2007 and this works for me.

You don't need to do anything else (the Button Code remains as is).

Let me know of issues.

Option Explicit
Dim myStore As String
Dim ws As Worksheet
Dim rng As Range
Dim SigString As String
Dim Signature As String

Sub test()
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "CONTACTS" And ws.Name <> "DATA" Then
            With ws
                myStore = .Range("A6")

                With Sheets("CONTACTS").Range("A:A")
                    Set rng = .Find(What:=myStore, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                    If Not rng Is Nothing Then
                        If rng.Offset(0, 3).Value Like "?*@?*.?*" Then
                            Call Create_PDF
                        Else
                            GoTo SkipMe
                        End If
                    End If
                End With
            End With
        End If
SkipMe:
    Next ws
End Sub

Sub Create_PDF()
    Dim strSubject As String
    Dim strBody As String
    Dim strTo As String
    Dim strCC As String
    Dim Filename As String
    Dim myPath As String

    myPath = ThisWorkbook.Path & "\"
    strSubject = "Enter Your Subject Here"  '<----------------
    strBody = "Enter Your Body Message Here"  '<----------------
    strTo = rng.Offset(0, 3).Value
    strCC = ""

    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            myPath & myStore & ".pdf" _
            , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
    Filename = myPath & myStore & ".pdf"

    If Filename <> "" Then
        RDB_Mail_PDF_Outlook Filename, strTo, strCC, strSubject, strBody, False    '<---Change to True to Auto Send Mail
    Else
        MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                "Microsoft Add-in is not installed" & vbNewLine & _
                "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                "You didn't want to overwrite the existing PDF if it exist"
    End If
    Kill Filename
End Sub


Function RDB_Mail_PDF_Outlook(FileNamePDF As String, strTo As String, strCC As String, _
        strSubject As String, strBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    'Change only Mysig.txt to the name of your signature
    SigString = Environ("appdata") & _
            "\Microsoft\Signatures\jas.txt" '<---Modify jas.txt to the name of your Signature

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    With OutMail
        .To = strTo
        .CC = strCC
        .BCC = ""
        .Subject = strSubject
        .Body = strBody & vbNewLine & vbNewLine & Signature
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Hi Linda

Use Line Feeds (vbCrLf) like so (a single Line Feed for New Sentence...a Double Line Feed for a New Paragraph)

strBody = "This is the First Paragraph. This is the First Paragraph. This is the First Paragraph. This is the First Paragraph." _
            & vbCrLf & "This is the First Paragraph. This is the First Paragraph. This is the First Paragraph. This is the First Paragraph." & vbCrLf & vbCrLf & _
            "This is the Second Paragraph. This is the Second Paragraph. This is the Second Paragraph. This is the Second Paragraph." & vbCrLf & vbCrLf & _
            "This is the Third Paragraph."

You're welcome...glad I could help.