VBA emailing of several independent pdf files to one email adress

Sapron75

New Member
Joined
Jun 6, 2016
Messages
15
Hi , I want to create several pdf's and send it to only one email address. The code I have will make individual emails with individual pdf's, so if I have a group members which belong to 1 email address, the group's pdf's should be sent in one email to the head of the group.

This is the code which sends only individual emails I think it must be done with a filter, but I can't get it right. Colomn "W" contain the email addresses :

Code:
Sub WordDocumentenmaken()
Dim CusRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName, TemplateBonusgrAfhank As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Blad16

If Range("B3").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("D1").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Template rij vaststellen
TemplName = .Range("D1").Value 'Template naam vasstellen
DocLoc = Blad1.Range("B" & TemplRow).Value 'Word document naam

'Open het word document template
On Error Resume Next 'Als Word toevallig al loopt
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Nieuw Word sessie starten
Err.Clear
'Wanneer fout dan foutbehandeling
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Maakt Word zichtbaar voor gebruiker
End If
LastRow = .Range("C999").End(xlUp).Row 'Laatste rij in tabel bepalen
For CustRow = 6 To LastRow
TemplateBonusgrAfhank = .Range("AB" & CustRow).Value
                If TemplName <> .Range("Z" & CustRow).Value And TemplName = .Range("AB" & CustRow).Value Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open de template
For CustCol = 3 To 20 'Dit zijn alle kolommen met de tag naam
TagName = .Cells(5, CustCol).Value 'Je geeft de rijnummer op waarin de tags staan vermeld
TagValue = .Cells(CustRow, CustCol).Value ' Tag waarde
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:=True, Wrap:=wdFindContinue
End With
Next CustCol
If .Range("G1").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("C" & CustRow).Value & " " & .Range("F" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("H" & CustRow).Value & " - " & .Range("U" & CustRow).Value & ".pdf" 'creeert file met persnr,voorletter, tussenvoegsel,achternaam en Bonus subgroup
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else 'Als het in Word moet
FileName = ThisWorkbook.Path & "\" & .Range("C" & CustRow).Value & " " & .Range("F" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("H" & CustRow).Value & " - " & .Range("U" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
 .Range("Z" & CustRow).Value = TemplName 'Template Name
 .Range("AA" & CustRow).Value = Now
If .Range("G2").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.Createitem(0)
With OutMail
.To = Blad16.Range("W" & CustRow).Value
.CC = Blad16.Range("X" & CustRow).Value & ";" & Blad16.Range("Y" & CustRow).Value
.Subject = "Bonus letter(s) of your team"
.Body = "Dear " & Blad16.Range("D" & CustRow).Value & " , attached you will find the bonus letter(s) for your team. Please ensure they receive this letter individually within 1 week after receiving this e-mail."
.Attachments.Add FileName
.Display 'Als je zonder van tevoren wilt zien dan .Display to.Send
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Gooit de pdf of word document weg wat je hebt aangemaakt
End If
Next CustRow
WordApp.Quit
End With
End Sub

Thank you in advance !!
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top