Macro emailer help

[mikeflo94]

Good Morning/Afternoon for everybody.

I work for this company where they have a spreed sheet with 4 tabs: 1. Data 2. Shipper 3. Emailer 4. Addresses.

The objective of the workbook is to send emails to different people but filter data. (the addresses of the people is int he Address tab, the data is in the Data tap, and in the shipper it filters for the available shippers to send. Depending on the data i input in the Data tab.)

Now so far I am able to get the spreadsheet to filter the shipper and to send it manually one by one. The idea is to click send and send emails to all people I have in the address tab at the same time. Now, the email must contain a simple good afternoon text and signature and a the attached pdf containing the data for every sender.

Keeping in mind the data is different for every plant/person/email.

Any help would be greatly appreciated.

Since this is a new account I am unable to attach the file in this post. But I am linking the file via Google Drive. https://drive.google.com/file/d/0B5kzJU9ystXBamZVTXhKSUp5ekk/view?usp=sharing
if there is any issue with the file let me know please.

Key:
I am using Excel 365 Plus version.
In windows 10
and I always have outlook open with my company email.

Thank you in advance and excuse my English. (not my first language)

 

[Worf]

Welcome to the Board

Please test the code below:

Sub Main()                                                          ' run this one
Dim s$, i%, ad, ws As Worksheet, cell As Range, eml As Worksheet
Set eml = Sheets("emailer")
Set ws = Sheets("addresses")
For Each cell In ws.Range(ws.Cells(2, 1), ws.Cells(ws.Range("a" & Rows.Count).End(xlUp).Row, 1))
    eml.[b2:b5] = WorksheetFunction.Transpose(cell.Resize(, 4))
    eml.Activate
    Sheets("Data").[a1].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[b1:b2], _
    CopyToRange:=[outputHeaders], Unique:=False
    AttachActiveSheetPDF cell.Row
Next
End Sub


Sub AttachActiveSheetPDF(j%)
Dim IsCreated As Boolean, i As Long, outlapp, PdfFile$
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & j & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=0, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error Resume Next
Set outlapp = GetObject(, "Outlook.Application")
If Err Then
    Set outlapp = CreateObject("Outlook.Application")
    IsCreated = True
End If
outlapp.Visible = True
On Error GoTo 0
With outlapp.createitem(0)
    .to = CStr(Range("emailCell"))
    .CC = CStr(Range("ccCell"))
    .Subject = CStr(Range("subjectCC"))
    .body = CStr(Range("bodyCell"))
    .Attachments.Add PdfFile
    .Display
End With
Kill PdfFile
'If IsCreated Then OutlApp.Quit
Set outlapp = Nothing
End Sub