Macro for attaching multiple files in outlook from a dynamic formula

[Badger21]

Hello all,

I am hoping you can help me with my issue. I have created a few macros now that create an email message with attachments when I have the file name pointed to a specific source (or cell value). But I am trying to write a marco to insert file names based on a formula that is returned into multiple cells. I have a form that someone will fill out and the vaule I am trying to extract is an invoice number. The number maybe unique or repeated multiple times depending on the situation.

I have created the following formula to get a list of unique values in the cells.
=IFERROR(IF(INDEX('Fill Form'!$E$22:$E$27,MATCH(0,INDEX(COUNTIF($T$11:T11,'Fill Form'!$E$22:$E$27),),0))=0,"",INDEX('Fill Form'!$E$22:$E$27,MATCH(0,INDEX(COUNTIF($T$11:T11,'Fill Form'!$E$22:$E$27),),0))),"")

My goal is to attach files in an email, using the output of this formula to start the reference of the file name I want to insert. I have this formula outputing to 6 cells (because that is currently the maximum number of values that can be input), and I may have less unique values than the maximum of 6. I can write code to reference each of the 6 cells to as the start of the file name, but my concern is that the macro will break when I refer to a cell that does not have a value in it.

This is what I have written for code so far.

On Error GoTo ErrHandler

Sheets("Approval Form").Select

Dim Path As String
Dim filename1 As String
Dim Path2 As String
Dim filname2 As String
Dim Path3 As String
Dim

Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

Path = Sheets("Fill Form").Range("T6").Value
filename1 = Sheets("Fill Form").Range("T4").Value

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & "APPROVAL for" & filename1 & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True

With objEmail
.To = Sheets("Fill Form").Range("T9")
.CC = Sheets("Fill Form").Range("T8")
.Subject = Sheets("Fill Form").Range("T4") & " APPROVAL NEEDED"
.Body = "Hello," & vbNewLine & vbNewLine & "Please see attached approval forms for the following vendor invoices:" & vbNewLine & vbNewLine & Sheets("Fill Form").Range("T12") & vbNewLine & Sheets("Fill Form").Range("T13") & vbNewLine & Sheets("Fill Form").Range("T14") & vbNewLine & Sheets("Fill Form").Range("T15") & vbNewLine & Sheets("Fill Form").Range("T16") & vbNewLine & Sheets("Fill Form").Range("T17") & vbNewLine & vbNewLine & "Thank You"
.Attachments.Add (Path & filename1 & ".pdf")

.Display

End With
ErrHandler:

Any help is greatly appreciated!

 

[sijpie]

Hi Badger21, welcome to the forum. Just a couple of things to help everybody (including yourself) along. When posting code, please insert the code between code brackets. Just above the post entry field there are a few icons, one of which has the word VBA in it. Click on that and paste your code.

Any reason why you have an empty err handler? In general, do not stop errors from doing their standard behaviour, specifically not while you are developing your code. THere are a few legit reasons to do so, else it is bad programming. You need to account for possible problems in your code, by checking if things exist, etc. You will see that is being done in the modified code below.

You want to loop through the range of cells with the filenames. And you want to do that in a handy place.
Also you want to catch any empty cells, that is pretty straightforward.

Note the remarks, particularly those starting with <<<<<<. They will need your attention

'    On Error GoTo ErrHandler   'Unless good reason, don't do this. And if so, ensure the err handler does something
   
    Sheets("Approval Form").Select
   
    Dim rInput As Range, rC As Range
    Dim sPath As String, sFileName As String, sPDFName As String
'    Dim Path2 As String        don't need all these, will loop through each name
'    Dim filname2 As String
'    Dim Path3 As String
    Dim wbWB As Workbook
   
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
   
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)
   
    Set rInput = Sheets("Fill Form").Range("T1:T6") '<<<<<<<<<<  Range where the six filenames will be sitting, adjust to suit
    sPath = Sheets("Fill Form").Range("T8").Value   '<<<<<<<<<<  Cell where the path will be stored
   
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"  ' make sure path has path separator
   
    With objEmail
    .To = Sheets("Fill Form").Range("T9")
    .CC = Sheets("Fill Form").Range("T8")
    .Subject = Sheets("Fill Form").Range("T4") & " APPROVAL NEEDED"
    .Body = "Hello," & vbNewLine & vbNewLine & "Please see attached approval forms for the following vendor invoices:" & vbNewLine & vbNewLine _
            & Sheets("Fill Form").Range("T12") & vbNewLine & Sheets("Fill Form").Range("T13") & vbNewLine _
            & Sheets("Fill Form").Range("T14") & vbNewLine & Sheets("Fill Form").Range("T15") & vbNewLine _
            & Sheets("Fill Form").Range("T16") & vbNewLine & Sheets("Fill Form").Range("T17") & vbNewLine & vbNewLine & "Thank You"
   
    For Each rC In rInput.Cells
        'Loop through each of the cells holding the various excel filenames
        sFileName = rC.Value
        If sFileName Like "*.xls*" Then   ' check if '.xls' appears in the value. It can be assumed thaty is a valid Excel file
            'I dont understand wat you are trying to do in the next line. You are exporting the current sheet of the workbook running the macro. _
             But I think you want to export a sheet from the workbook sFileName.
'            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                            FileName:=Path & "APPROVAL for" & sFileName & ".pdf", _
                                            Quality:=xlQualityStandard, _
                                            IncludeDocProperties:=False, _
                                            IgnorePrintAreas:=False, _
                                            OpenAfterPublish:=True          ' Don't you want to set this as false? Else your view of the email gets obstructed by a bunch of pdf's.
            '<<<< Line Above = your version
            'or
            '>>>> Lines below = open each book and print active sheet
            Set wbWB = Application.Workbooks.Open(sPath & sFileName)
            'check if opened
            If Not wbWB Is Nothing Then
                sPDFName = Path & "APPROVAL for" & sFileName & ".pdf"
                wbWB.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                                    FileName:=sPDFName, _
                                                    Quality:=xlQualityStandard, _
                                                    IncludeDocProperties:=False, _
                                                    IgnorePrintAreas:=False, _
                                                    OpenAfterPublish:=False
                'then add to email as attachment
                .Attachments.Add (sPDFName)
            End If
        End If
    Next rC
    .Display
   
    End With
'ErrHandler: