VBA Add multiple attachments to an email

[willow1985]

I have the below code that converts and saves 2 worksheets to pdfs and then creates an email.

What I would like to add is code that attaches every document from column C from its corresponding directory in column D.
Column C and D may change (become longer or shorter) depending on what files the user wants to attach.

Any help with modifying this code would be greatly appreciated.

OPS 068 Rev 17 and OPS 069 Rev 17.xlsm
	A	B	C	D
1	Customer:	E Metals	Documents to Attach	Directories
2	Contact:	Carole Smith	WTC amo.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
3	Email:	Carole.Smith@notreal.com	WTC comp.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
4			ISO TRC.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
5			RC Wpg.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
6			RR Wpg.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
7			RRT Wpg.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
8			OPS 068.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
9			OPS 069.pdf	X:\ADMINISTRATION\QAEng\Carla's Documents\Project\
Input

Sub Email()
'
' Email Macro
'
Dim Path As String
Dim filename As String

Path = Sheets("Input").Range("D8")
filename = Sheets("Input").Range("C8")

Sheets("OPS 068").Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Path & filename & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True

Dim Path2 As String
Dim filename2 As String

Path2 = Sheets("Input").Range("D9")
filename2 = Sheets("Input").Range("C9")

Sheets("OPS 069").Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Path2 & filename2 & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
'
Sheets("Input").Select

  Dim outlookApp As Object, MItem As Object
  Set outlookApp = CreateObject("Outlook.Application")
  Set MItem = outlookApp.CreateItem(0)
  With MItem
    .To = Sheets("Input").Range("B3")
    .Subject = "Supplier Survey"
    .Body = "Good Afternoon " & Sheets("Input").Range("B2") & vbCrLf & vbCrLf & "Please find attached our documents." & vbCrLf & vbCrLf & "Please let us know if you require anything further"
    .Display
  End With


End Sub

 

[willow1985]

Figured it out. I combined Column C with D in Column E and modified it as follows:

Sub Email()
'
' Email Macro
'
Application.ScreenUpdating = False

Dim Path As String
Dim filename As String

Path = Sheets("Input").Range("D8")
filename = Sheets("Input").Range("C8")

Sheets("OPS 068").Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Path & filename & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False

Dim Path2 As String
Dim filename2 As String

Path2 = Sheets("Input").Range("D9")
filename2 = Sheets("Input").Range("C9")

Sheets("OPS 069").Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Path2 & filename2 & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False
'
Sheets("Input").Select

  Dim outlookApp As Object, MItem As Object
  Set outlookApp = CreateObject("Outlook.Application")
  Set MItem = outlookApp.CreateItem(0)
  Set ws = Sheets("Input")
 
  With ws
    Set rngAttach = ws.Range(ws.[E2], ws.Cells(Rows.Count, "E").End(xlUp))
End With

  With MItem
    .To = ws.Range("B3")
    .Subject = "Supplier Survey"
    .Body = "Good Afternoon " & ws.Range("B2") & vbCrLf & vbCrLf & "Please find attached our documents." & vbCrLf & vbCrLf & "Please let us know if you require anything further"
    For Each rng1 In rngAttach.Cells
        If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
    Next
    .Display
  End With

Application.ScreenUpdating = True

End Sub

Would still like to see other solutions though if anyone wishes to post.

Thank you for reading this!

 

[Kenneth Hobson]

That looks fine. I would suggest changing this line though:

' Set rngAttach = ws.Range(ws.[E2], ws.Cells(Rows.Count, "E").End(xlUp))
Set rngAttach = ws.Range(ws.[E2], ws.Cells(ws.Rows.Count, "E").End(xlUp))

ws.[E2] is fine but "E2" would have worked too.