VBA Excel- Attaching multiple files and send email

[zinah]

Hi,

I have an excel sheet that has list of employees, and I need to send emails to each employee with specific file (depends on Employee ID), I named the files logically so that the macro attach the right file. I have below macro which works fine, and it create email and attach the required file. However, for some cases, I have some employees that have more than one files to attach. How can I make a condition that create one email per Employee and attach all the files in one email instead of separate emails?

Sub CreateNewMessage()Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object


Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)




Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailMid1, emailMid2, emailMid3, emailClose, emailCustom, emailSig As String


Dim AttachmentPath, AttachmentNm As String
    AttachmentPath = "C:\Users\""\Documents\"




For Each ToCc In ActiveSheet.[A2:A3]
'''1em = 12pt = 16px = 100%
    'Large is 18 px which is around 13.5 pt
    'Larger is 19 px which is around 14 pt
    'Medium is 16 px which is around 12 pt
    'Small is 13 px which is around 10 pt
    'Smaller is 13 px which is around 10 pt
    'X-large is 24 px which is around 18 pt
    'X-small is 10 px which is around 7.5 pt
    'XX-large is 32 px which is around 24 pt
    'XX-small is 9 px which is around 7 pt


'=============================================================


Dim ToEmail, CcEmail, ToNm, CcNm As String
Dim DescrDt, LocID, DescrNm As String


    ToNm = Cells(ToCc.Row, [C1].Column).Value
    CcNm = Cells(ToCc.Row, [G1].Column).Value
    ToEmail = Cells(ToCc.Row, [E1].Column).Value
    CcEmail = Cells(ToCc.Row, [I1].Column).Value


    LocID = Cells(ToCc.Row, [K2].Column).Value
   ' DescrNm = Cells(ToCc.Row, [D1].Column).Value
   ' DescrNm = Cells(ToCc.Row, [K2].Column).Value
    DescrDt = "20190401"




    AttachmentNm = "Monthly Attrition_" & DescrDt & "__" & LocID & ".pdf"


Dim FileAttach As String
    FileAttach = AttachmentPath & AttachmentNm
   ' MsgBox FileAttach
    
'Exit Sub


'=============================================================


Set aEmail = aOutlook.CreateItem(0)


With aEmail
  .SentOnBehalfOfName = "name@company.com"
  .To = ToEmail
  .cc = CcEmail '& "; " & SupvEmail & "; " & HREmail
  .Subject = "Monthly Dashboard " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
  '.Sensitivity = olConfidential
  .Attachments.Add FileAttach
  
    .display
'    .send
End With




NEXT_ToCC:
    Set aEmail = Nothing
    Set olInsp = Nothing
    Set myDoc = Nothing
    Set oRng = Nothing
Next ToCc




End Sub

 

[zinah]

I can give more details if required, but any thoughts/codes on above macro to accommodate my inquiry?

 

[zinah]

Hi,

Can anyone help me with this macro please?