VBA emailing of several independent pdf files to one email adress

[Sapron75]

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 :

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 !!