One Click Excel Information and send out thru Email

[TraceyNoe]

Can you please help me with making this happen?

1.) Just to keep this simple...Here is the raw Data from Excel (These cells are formatted with boarder lines surrounding each cell)

[TABLE="width: 642"]
[TR]
[TD]PO Date[/TD]
[TD]Po#[/TD]
[TD]Vendor[/TD]
[TD]Provide Tracking#[/TD]
[TD]Vendor Email[/TD]
[/TR]
[TR]
[TD]3/15/19[/TD]
[TD]WZ-54244-P[/TD]
[TD]NISSAN[/TD]
[TD][/TD]
[TD]tracey.noe@abc.com[/TD]
[/TR]
[TR]
[TD]2/12/19[/TD]
[TD]WZ-12574-P[/TD]
[TD]VALLEN[/TD]
[TD][/TD]
[TD]tracey.noe@xyz.com[/TD]
[/TR]
[TR]
[TD]4/7/19[/TD]
[TD]WZ-65544-P[/TD]
[TD]VALLEN[/TD]
[TD][/TD]
[TD]tracey.noe@xyz.com[/TD]
[/TR]
[TR]
[TD]5/5/19[/TD]
[TD]WZ-32711-P[/TD]
[TD]NEATNOE[/TD]
[TD][/TD]
[TD]ttt@yahoo.com[/TD]
[/TR]
[TR]
[TD]2/27/19[/TD]
[TD]WZ-85117-P[/TD]
[TD]VALLEN[/TD]
[TD][/TD]
[TD]tracey.noe@vallen.com[/TD]
[/TR]
[TR]
[TD]2/12/19[/TD]
[TD]WZ-12574-P[/TD]
[TD]NISSAN[/TD]
[TD][/TD]
[TD]tracey.noe@abc.com[/TD]
[/TR]
[/TABLE]

2.) These rows are in no particular order. The end result that I need to make happen is....(In BEST case scenario...each day open the excel report and click 1 button and all lines associated with the same email address all get sent to those emails individually at one time That would include the exact subject, body and signature ....or in the next best scenario...If I have to I could first sort by the email addresses and then click one email address and it would pull all rows associated with that email address and send it. Then I would go to the next email address and send and so forth.

3.) I need this to be as automated as possible. Please assist on how this can be done.

Thank you,
Tracey Noe

 

[BigDawg15]

Joe4,

That seems to have corrected the problem so far. I will try to post the solution again.

Thank you,

BigDawg15

 

[BigDawg15]

Tracey,

Add Sheet2 to your workbook and add data as follows:

[TABLE="width: 755"]
[TR]
[TD="width: 104, bgcolor: transparent"]Name
[/TD]
[TD="width: 110, bgcolor: transparent"]Vendor
[/TD]
[TD="width: 222, bgcolor: transparent"]Vendor Email
[/TD]
[TD="width: 307, bgcolor: transparent"]File1
[/TD]
[TD="width: 263, bgcolor: transparent"]File2
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]Tracey
[/TD]
[TD="width: 110, bgcolor: transparent"]Nissan
[/TD]
[TD="bgcolor: transparent"]sample1.we@Nissan.com

[/TD]
[TD="width: 307, bgcolor: transparent"]C:\Temp\Nissan.pdf

[/TD]
[TD="width: 263, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]Sarah
[/TD]
[TD="width: 110, bgcolor: transparent"]Vallen
[/TD]
[TD="bgcolor: transparent"]sample2.we@vallen.com

[/TD]
[TD="width: 307, bgcolor: transparent"]C:\Temp\Vallen.pdf

[/TD]
[TD="width: 263, bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]Jim
[/TD]
[TD="width: 110, bgcolor: transparent"]Neatnoe
[/TD]
[TD="bgcolor: transparent"]sample3.we@yahoo.com

[/TD]
[TD="width: 307, bgcolor: transparent"]C:\Temp\Neatnoe.pdf

[/TD]
[TD="width: 263, bgcolor: transparent"][/TD]
[/TR]
[/TABLE]


Go to the VBA editor and paste the following into a regularmodule:

[FONT=Calibri][SIZE=3][COLOR=#000000]Sub FilterDataToPDF()[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'Prepared by Dr Moxie[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim ws As Worksheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim ws_unique As Worksheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim DataRange As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim iLastRow As Long[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim iLastRow_unique As Long[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim UniqueRng As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim Cell As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim LastRow As Long[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim LastColumn As Long[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Application.ScreenUpdating =False[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    'Note that the macro willsave the pdf files in this active directory so you should save in anappropriate folder[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    DirectoryLocation = "C:\Temp\"          '<------You can change path PDF's arestored here[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set ws =Worksheets("Sheet1")     'Amend to reflect the sheet you wish to work with[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set ws_unique =Worksheets("Sheet2") 'Amend to reflect the sheet you wish to workwith[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    'Find the last row in eachworksheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    iLastRow =ws.Cells(Rows.Count, "A").End(xlUp).Row[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    iLastRow_unique =ws_unique.Cells(Rows.Count, "A").End(xlUp).Row[/COLOR][/SIZE][/FONT]


[FONT=Calibri][SIZE=3][COLOR=#000000]    With ws[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        'I've set my range toreflect my headers which are fixed for this report[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Set DataRange =ws.Range("$A$1:$E$" & iLastRow)[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        'autofilter field is 4 asI want to print based on the sub area value in column D[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        DataRange.AutoFilterField:=3[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        Set UniqueRng =ws_unique.Range("B2:B" & iLastRow_unique)                 'Email Files Worksheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        For Each Cell InUniqueRng[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            DataRange.AutoFilterField:=3, Criteria1:=Cell                       'Master Worksheet[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]       'FName = DirectoryLocation& "\" & Cell.Value & " Overdue Inspections"& ".pdf"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Fname = DirectoryLocation& "\" & Cell.Value & ".pdf"[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        ws.ExportAsFixedFormatType:=xlTypePDF, Filename:=Fname _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        ,Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        :=False, OpenAfterPublish:=False[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        Next Cell[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    End With[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    With ws[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        .ProtectUserinterfaceonly:=True, _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]         DrawingObjects:=False,Contents:=True, Scenarios:= _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        True,AllowFormattingColumns:=True, AllowFormattingRows:=True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]         .EnableOutlining = True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]         .EnableAutoFilter = True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]         If .FilterMode Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            .ShowAllData[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]         End If[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]     End With[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Application.ScreenUpdating =True[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]   Range("A1:E36").AdvancedFilter Action:=xlFilterInPlace,Unique:=False[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    ActiveSheet.Unprotect[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Range("A1").Select[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]Send_Files[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub[/COLOR][/SIZE][/FONT]

Paste the following into another regular module:

[FONT=Calibri][SIZE=3][COLOR=#000000]Sub Send_Files()[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'Working in Excel 2000-2016[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim OutApp As Object[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim OutMail As Object[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim sh As Worksheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim Cell As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim FileCell As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim rng As Range[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    With Application[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        .EnableEvents = False[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        .ScreenUpdating = False[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    End With[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set sh =Sheets("Sheet2")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set OutApp =CreateObject("Outlook.Application")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    For Each Cell Insh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        'Enter the path/filenames in the C:Z column in each row[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Set rng =sh.Cells(Cell.Row, 1).Range("d1:e1")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        If Cell.Value Like"?*@?*.?*" And _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]          Application.WorksheetFunction.CountA(rng) > 0 Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            Set OutMail =OutApp.CreateItem(0)[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]            With OutMail[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                .To = Cell.Value[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                .Subject ="Invoice Tracking Data"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                .Body = "Hi" & Cell.Offset(0, -2).Value & "," & _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                        vbNewLine& vbNewLine & "Please review the attached document and forward meany updates." & _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                        vbNewLine& vbNewLine & "Thank you," & vbNewLine & vbNewLine& "Tracey Noe"[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]                For Each FileCellIn rng.SpecialCells(xlCellTypeConstants)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                    IfTrim(FileCell) <> "" Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                        IfDir(FileCell.Value) <> "" Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                           .Attachments.Add FileCell.Value[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]   Kill FileCell.Value   '<------Comment this line out if you wantto keep the pdf file created during this process[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]                        End If[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                    End If[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                Next FileCell[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]                .Display  'Or use .send[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            End With[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]            Set OutMail = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        End If[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Next Cell[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set OutApp = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    With Application[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        .EnableEvents = True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        .ScreenUpdating = True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    End With[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub[/COLOR][/SIZE][/FONT]

Run the FilterDatatoPDF macro and the macros will createfiltered pdf files for each vendor and attach it to an email for each vendor.

Any problems post back here.
Regards,
BigDawg15

 

[TraceyNoe]

Thank you very much for all your help!!!