Send Multiple emails to list of users/names in a sheet, filtering each user(name) own data from another sheet and sending email attaching pdf

[foratoms]

I am designing an excel tool that sends end of month Account Summary to colleagues emails while attaching the summary as pdf. The list of staff is already in a worksheet named "Staff Record" starting from cell S2. The staff emails is listed in column U starting from cell U2. The transaction record data to be filtered by name of staff is in Worksheet "Report" where cell E1 dropdown of all names from "Staff Record!S2" so that the worksheet is auto filtered every time a new name is selected serially from the drop-down. I have scrapped different codes on the internet but not perfect yet. As it is, I get numerous popups asking for the username, email and mails to send to for every cycle. This means I keep getting popup for txtuser (username) and names for 500 times if I have to send to 500 staff on the list! that is killing.

I want the code to

1. go through and pick the staff names in the dropdown in cell E1 of "Report" one by one,
2. filter the record based on the staff name and the specified date range (contained in column F (will only ask once as a pop up and be used throughout the code running),
3. create a pdf of the filtered record by the name and period and
4. create an email object with the email address of the recipient looked up in corresponding email column U of "staff Record. Column U contain the email to copy "Cc"
5. Create Salutation by using the first name from the name chosen. e.g. "Dear James," if James Howards is selected as the name. 7)send the email with filtered pdf record of the staff as attachment
6. repeat the process 1-7 for all names, going through the dropdown list one by one
7. terminate when it gets to the last name on the list and give the message "emails sent"

below is my code. PLEASE SAVE A FRUSTRATED SOUL

Sub SendEmail()
Dim wPath As String, wFile As String
Dim x As Date
Dim ws As Worksheet
Dim ws_unique As Worksheet
Dim DataRange As Range
Dim iLastRow As Long
Dim iLastRow_unique As Long
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long


StartDate = InputBox("Start Date in 'MM/DD/YYYY")
End_Date = InputBox("End Date in 'MM/DD/YYYY")

StDate = StartDate
EndDate = End_Date

Application.ScreenUpdating = False


DirectoryLocation = ActiveWorkbook.Path

Set ws = Worksheets("Report") 
Set ws_unique = Worksheets("Staff Record") 

'Find the last row in each worksheet
iLastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
iLastRow_unique = ws_unique.Cells(Rows.Count, "S").End(xlUp).Row


With ws
    'I've set my range to reflect my headers which are fixed for this report
    Set DataRange = ws.Range("$C$4:$Q$" & iLastRow)

    Set UniqueRng = ws_unique.Range("S2:S" & iLastRow_unique)
    For Each Cell In UniqueRng
        DataRange.AutoFilter Field:=3, Criteria1:=Cell
        DataRange.AutoFilter 4, ">=" & StDate, xlAnd, "<=" & EndDate

       
        wPath = ThisWorkbook.Path & "\"
        wFile = DirectoryLocation & "\" & Cell.Value & " Account Statement" & ".pdf"
        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=wFile, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False


        x = Format(Now(), "dd-mmm-yyyy")
        Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
        txtUser = InputBox("Staff Name", "Name of Recipient")
        email = InputBox("What is the email address?")
        ccemail = InputBox("What email address do you want to copy? (separated wih column)")
        dam.to = email
        dam.cc = ccemail
        dam.Subject = "Account Statement - Generated on " & x
        dam.Body = "Hello " & txtUser _
        & ", Please find attached your account statement as generated today: " & x & "."
        dam.Attachments.Add wFile
        dam.Send


Next Cell

End With
With ws
     .Protect Userinterfaceonly:=True, _
     DrawingObjects:=False, Contents:=True, Scenarios:= _
    True, AllowFormattingColumns:=True, AllowFormattingRows:=True
     .EnableOutlining = True
     .EnableAutoFilter = True
     If .FilterMode Then
        .ShowAllData
     End If
 End With
Application.ScreenUpdating = True

MsgBox "Emails sent"

 

[ranman256]

http://users.qx.net/scook/xfer/email data via user list.xls

example of email list and sample data